//EIQ2GPBV JOB TIME=(0,30) COMPILE VERSATEC VERSION OF PROGRAM DRAW. /*SCHEDULE PRIORITY=0.7 //CLEAR EXEC PGM=IEFBR14 FIRST, CLEAR ANY EXISTING LOAD MODULES //DD1 DD DSN=EIQ2GPB.VERSMOD,DISP=(OLD,DELETE) CALLED VERSMOD. //FORT EXEC PGM=FORTVS,REGION=3072K RUN COMPILER: //STEPLIB DD DISP=(SHR,PASS),DSN=APP1.FORTVS.COMPILER VS-FORT 2.4.0 //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 OR BLACK-AND-WHITE ON VERSATEC SPECTRUM. 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 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 -VERSATEC ROUTINES: CIRCLE,DEFPAT,DEFPEN, C NEWPEN,PAPER,PENCLR, C PLOT,PLOTS,RECT,SETFNT,SETPAT,SYMBOL, C TONCLR,TONE,TONFLG,VPOPT,VPORT,WINDOW. C CHARACTER*80 TITLE CHARACTER*8 ASTER,BLANKS DOUBLE PRECISION CODE,FLOWIN LOGICAL ALDONE,ALLREP,BOXIT,COLOR,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), 3 GEOTHA(4,7,N50),GEOTHC(4,7,N50),GEOTHM(4,7,N50), 4 GLUEC(7,N50),GLUEM(7,N50),DNLINK(3,7,N50), 5 UPLINK(3,7,N50),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),XSTT(NSTATE),YST(NSTATE),YSTT(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.) C DATA (NODES(J,0),J=1,6)/1,1,1,1,1,1/ DATA RINKM /6371./ 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 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) C 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 XSTT(I)=XST(I) YSTT(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(INDATA, 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,SZZBC,SZZBM, 2 TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM, 3 THIKC,THIKM,TIME,THNKC,THNKM,TOFSTC,TOFSTM, 4 TOUCHC,TOUCHM,TSLAB0,TSURF,UPLINK,VC,VM,VISMAX, 5 VSLABC,VSLABM,WC,WM,XIPC,XIPM, 6 XNODC,XNODM,YIPC,YIPM,YNODC,YNODM, 7 ALDONE,NELROW,FROMWC,FROMWM,WANDES, 8 IBELOW,NTREAD,TITLE,HMAX,HMIN, 9 CPNLAT,X0ELON,Y0NLAT) IF (STATES.AND.RETRO) THEN CALL GETSCA (INPUM,XNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,XSTT) CALL GETSCA (INPUM,YNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,YSTT) DO 5678 I=1,NXYST IF (STLINK(1,I).LT.1.0) THEN XSTT(I)=XST(I) YSTT(I)=YST(I) ENDIF 5678 CONTINUE ENDIF ISTEP=1 CALL REPORT (ISTEP,XIPC,XIPM,YIPC,YIPM, 2 XNODC,XNODM,YNODC,YNODM,TITLE,VM,NODES, 3 OUTSCA,OUTVEC,VC,ERATEM,ERATEC, 4 THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, 5 GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, 6 TIME ,NUMNOD,NUMEL, 7 G,HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, 8 SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, 9 TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CODE,CONDNS,DETJC,DETJM,FAILUR,FLOWIN, 1 NCDIM,NDIFF,NXL,LWORK,WC,WM, 2 SZZBC,SZZBM,TOUCHC,TOUCHM, 3 ECLOG,RADIUS,SLABSZ,CPNLAT,X0ELON,Y0NLAT, 4 VSLABC,VSLABM,OUTV2,RAMP, 5 THNKC,UPLINK,TASTH,TSLAB0, 6 DOPLOT,SCALEC,NCONTR, 7 STATES,RMSVEC,NELCOL,PHINOD,DRAWST, 8 NXYST,XSTT,YSTT,NELROW,THNKM,FBLAND,LOWBLU, 9 CINT,FROMWC,FROMWM,IBELOW,WANDES,CONINT,CONNOD B ,TSURF,PUSHUP,IPENCT,IPENST,IPENLB,COLOR) 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,SZZBC,SZZBM, 2 TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM, 3 THIKC,THIKM,TIME,THNKC,THNKM,TOFSTC,TOFSTM, 4 TOUCHC,TOUCHM,TSLAB0,TSURF,UPLINK,VC,VM,VISMAX, 5 VSLABC,VSLABM,WC,WM,XIPC,XIPM, 6 XNODC,XNODM,YIPC,YIPM,YNODC,YNODM, 7 ALDONE,NELROW,FROMWC,FROMWM,WANDES, 8 IBELOW,NTREAD,TITLE,HMAX,HMIN, 9 CPNLAT,X0ELON,Y0NLAT) IF (ALDONE) GO TO 10000 IF (STATES.AND.RETRO) THEN CALL GETSCA (IMPUT,XNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,XSTT) CALL GETSCA (IMPUT,YNODC,NODES,NUMEL1,NUMNOD,STLINK, + OUTPUT,YSTT) DO 6789 I=1,NXYST IF (STLINK(1,I).LT.1.0) THEN XSTT(I)=XST(I) YSTT(I)=YST(I) ENDIF 6789 CONTINUE ENDIF CALL REPORT (ITIME,XIPC,XIPM,YIPC,YIPM, 2 XNODC,XNODM,YNODC,YNODM,TITLE,VM,NODES, 3 OUTSCA,OUTVEC,VC,ERATEM,ERATEC, 4 THIKM,THIKC,GEOTHA,GEOTHC,CONDUC, 5 GEOTHM,DNLINK,VPMEAN,DVPBYE,DVPDT, 6 TIME ,NUMNOD,NUMEL, 7 G,HMAX,HMIN,RHOAST,RHOH2O,SIGHC,SIGHBM,SIGZZC, 8 SIGZZM,TAUMTC,TAUMTM,TAUZZC,TAUZZM, 9 TEMLIM,ONEKM,ESUMC,ESUMM,AREAC,AREAM, A CODE,CONDNS,DETJC,DETJM,FAILUR,FLOWIN, 1 NCDIM,NDIFF,NXL,LWORK,WC,WM, 2 SZZBC,SZZBM,TOUCHC,TOUCHM, 3 ECLOG,RADIUS,SLABSZ,CPNLAT,X0ELON,Y0NLAT, 4 VSLABC,VSLABM,OUTV2,RAMP, 5 THNKC,UPLINK,TASTH,TSLAB0, 6 DOPLOT,SCALEC,NCONTR, 7 STATES,RMSVEC,NELCOL,PHINOD,DRAWST, 8 NXYST,XSTT,YSTT,NELROW,THNKM,FBLAND,LOWBLU, 9 CINT,FROMWC,FROMWM,IBELOW,WANDES,CONINT,CONNOD B ,TSURF,PUSHUP,IPENCT,IPENST,IPENLB,COLOR) 9999 CONTINUE 10000 CONTINUE ENDIF 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 GREATEST PRINCIPAL STRAIN') 423 FORMAT(L11,1P,2E10.2,I2,' CRUSTAL ROTATION') 424 FORMAT(L11,1P,2E10.2,I2,' UPPER CRUSTAL THICKNESS') 425 FORMAT(L11,1P,2E10.2,I2,' LOWER CRUSTAL THICKNESS') READ(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 OR ELEMENT SIDES') READ(5,*) IPENST IPENST=MIN(IPENST,31) IPENST=MAX(IPENST,1) WRITE(6,430)IPENST 430 FORMAT(' ',I10,' PEN WEIGHT FOR STATE LINES, IF ANY') READ(5,*) IPENLB IPENLB=MIN(IPENLB,31) IPENLB=MAX(IPENLB,1) WRITE(6,431)IPENLB 431 FORMAT(' ',I10,' PEN WEIGHT FOR TEXT LABELS, AND (IF .GT.1)', + ' NODES') READ(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,SZZBC,SZZBM, 2 TASTH,TAUMTC,TAUMTM,TAUZZC,TAUZZM,TEMLIM, 3 THIKC,THIKM,TIME,THNKC,THNKM,TOFSTC,TOFSTM, 4 TOUCHC,TOUCHM,TSLAB0,TSURF,UPLINK,VC,VM,VISMAX, 5 VSLABC,VSLABM,WC,WM,XIPC,XIPM, 6 XNODC,XNODM,YIPC,YIPM,YNODC,YNODM, 7 ALDONE,NELROW,FROMWC,FROMWM,WANDES, 8 IBELOW,NTREAD,TITLE,HMAX,HMIN, 9 CPNLAT,X0ELON,Y0NLAT) 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 COMPUTE DISTANCE INLAND FROM "LEFT" EDGE OF CRUSTAL GRID, C FOR A WHOLE ARRAY OF INTEGRATION POINTS AT ONCE C DIMENSION FROMW(7,NUMEL),XIP(7,NUMEL),XNODC(NUMNOD), + YIP(7,NUMEL),YNODC(NUMNOD) NELCOL=NUMEL/(2*NELROW) NCOLN=2*NELCOL+1 NLL=NUMNOD-NCOLN+1 DO 100 M=1,7 DO 90 I=1,NUMEL X=XIP(M,I) Y=YIP(M,I) FROMW(M,I)= + HOWFAR(X,Y,NELROW,NCOLN,NLL,XNODC,YNODC) 90 CONTINUE 100 CONTINUE RETURN END C C C REAL FUNCTION HOWFAR (X,Y, + NELROW,NCOLN,NLL,XNODC,YNODC) C C COMPUTES ORTHOGONAL DISTANCE FROM "LEFT" EDGE OF CRUSTAL GRID, C FOR ANY SINGLE POINT. C 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 ERRER=(DS1+DS2+DS3)/3. DS1=DS1-ERRER DS2=DS2-ERRER DS3=DS3-ERRER DSTEP=MAX(ABS(DS1),ABS(DS2),ABS(DS3)) IF (DSTEP.GT. 0.10) THEN LIMIT=LIMIT+1 DS1=DS1*0.1/DSTEP DS2=DS2*0.1/DSTEP DS3=DS3*0.1/DSTEP ENDIF S1=S1+DS1 S2=S2+DS2 S3=S3+DS3 IF (LEFTY(IT)) THEN IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).AND. + (S1.GE.-0.1.AND.S1.LE.3.0).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-3.0.AND.S3.LE.1.1)) GO TO 150 ELSE IF ((NREFIN.LT.LIMIT.AND.LIMIT.LE.40).AND. + (S1.GE.-0.1.AND.S1.LE.1.1).AND. + (S2.GE.-0.1.AND.S2.LE.1.1).AND. + (S3.GE.-0.1.AND.S3.LE.1.1)) GO TO 150 ENDIF C C END OF LOOP TO REFINE INTERNAL COORDINATES IN ONE TRIAL ELEMENT C SHIST(1,NTRIED)=S1 SHIST(2,NTRIED)=S2 SHIST(3,NTRIED)=S3 IF (NTRIED.GE.50) THEN INLOOP=.TRUE. WRITE(6,201) M,I,X,Y 201 FORMAT('0INTEGRATION POINT ',I1,' IN ELEMENT ', + I3,' AT (',1P,E10.2,',',E10.2,') CAUSES ', + 'INFINITE LOOP IN LINKER.'/ + ' HISTORY OF SEARCH: ELEMENT S1 S2', + ' S3') 202 FORMAT(22X,I3,2X,3F12.4) DO 203 N=1,50 WRITE(6,202) ITHIST(N),(SHIST(K,N),K=1,3) 203 CONTINUE WRITE(6,204) ITHIST(49),(NODES(J,ITHIST(49)), + J=1,6),(XNOD2(NODES(J,ITHIST(49))),J=1,6), + (YNOD2(NODES(J,ITHIST(49))),J=1,6) WRITE(6,204) ITHIST(50),(NODES(J,ITHIST(50)), + J=1,6),(XNOD2(NODES(J,ITHIST(50))),J=1,6), + (YNOD2(NODES(J,ITHIST(50))),J=1,6) 204 FORMAT('0ELEMENT',I3,' NODES:',I3,5I10/ + 9X,'X:',1P,6E10.2/9X,'Y:',6E10.2) RETURN ENDIF IF (ODD(IT)) THEN IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF (LEFTY(IT)) THEN GO TO 500 ELSE IT=IT-1 GO TO 100 ENDIF ELSE IF(IT.GT.NELWID) THEN IT=IT-NELWID+1 GO TO 100 ELSE UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 900 ENDIF ELSE IT=IT+1 GO TO 100 ENDIF ELSE IF (S1.GT.0.) THEN IF (S2.GT.0.) THEN IF (S3.GT.0.) THEN GO TO 500 ELSE IF(MOD(IT,NELWID).NE.0) THEN IT=IT+1 GO TO 100 ELSE UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 900 ENDIF ELSE IF ((NUMEL2-IT).GE.NELWID) THEN IT=IT+NELWID-1 GO TO 100 ELSE UDLINK(1,M,I)=0. UDLINK(2,M,I)=0. UDLINK(3,M,I)=0. GO TO 900 ENDIF ELSE IT=IT-1 GO TO 100 ENDIF ENDIF 500 UDLINK(1,M,I)=IT+0.10 UDLINK(2,M,I)=S2 UDLINK(3,M,I)=S3 900 CONTINUE 1000 CONTINUE RETURN END 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.).AND. + (DNLINK(1,M,I).LE.0.)) THEN C C RESET BASE, BUT ALLOW THERMAL EVOLUTION C Z=THIKM(5,NUMEL) TBOT=GEOTHA(1,M,I)+ GEOTHA(2,M,I)*Z+ + GEOTHA(3,M,I)*Z**2+GEOTHA(4,M,I)*Z**3 CORREC=TASTH-TBOT GEOTHA(4,M,I)=GEOTHA(4,M,I)+CORREC/Z**3 ELSE C C RESET WHOLE BOUNDARY LAYER C GEOTHA(1,M,I)=TASTH GEOTHA(2,M,I)=0. GEOTHA(3,M,I)=0. GEOTHA(4,M,I)=0. ENDIF 90 CONTINUE 100 CONTINUE C C MANTLE LITHOSPHERE LAYER C CALL TMOHO (THIKM,NUMEL,GEOTHM,BIGNUM,OUTSCA) DO 200 M=1,7 DO 190 I=1,NUMEL TBOT=OUTSCA(M,I) XLEFT=FROMWM(M,I) IF (TOUCHM(M,I).GE.0.99) THEN TBOTC=TSLAB(TSURF,TSLAB0,XLEFT,ONEKM) ELSE TBOTC=TASTH ENDIF CORREC=TBOTC-TBOT GEOTHM(4,M,I)=GEOTHM(4,M,I)+CORREC/THIKM(M,I)**3 190 CONTINUE 200 CONTINUE C C CRUSTAL LAYER C DO 220 M=1,7 DO 210 I=1,NUMEL OUTSCA(M,I)=GEOTHM(1,M,I) 210 CONTINUE 220 CONTINUE CALL EXTRAP (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.EQ.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 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 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 BETAL /1.E+20,2185.,1738.,1419.,993.,463.,-1.E+20/ DATA RINKM/6371./ DATA ((COEFF(I,J,1),I=1,3),J=1,6)/ + 1.256000E+3, 0.000000 , 0.000000, + 5.130022E+2, 3.400447E-1, 0.000000, + -2.122960E+3, 4.330471 , -1.423388E-3, + -2.631799E+3, 5.698898 , -2.134993E-3, + 5.504894E+2, -8.305952E-1, 1.213217E-3, + 4.260000E+2, 0.000000 , 0.000000/ C ONEKM=RADIUS/RINKM DO 20 J=1,NUMEL DO 10 I=1,7 VSLAB(1,I,J)=0.3234E-06 VSLAB(2,I,J)=-0.8666E-07 SZZ(I,J)=ECLOG+SLABSZ*SQRT(50./100.) 10 CONTINUE 20 CONTINUE C RAMPKM=RAMP/ONEKM C DO 200 M=1,7 DO 100 I=1,NUMEL X=XIP(M,I) Y=YIP(M,I) ALPHA=(X-2.5831E+08)/ONEKM BETA=(Y+1.9218E+09)/ONEKM C DO 105 J=1,NUMHR IF(BETA.LE.BETAL(J).AND.BETA.GE.BETAL(J+1))THEN ALIM=COEFF(1,J,1)+BETA*COEFF(2,J,1)+BETA**2*COEFF(3,J,1) TOUCHI=AMAX1(0.,AMIN1(1.,(0.5-2.*(ALPHA-ALIM)/RAMPKM))) TOUCH(M,I)=TOUCHI ENDIF 105 CONTINUE 100 CONTINUE 200 CONTINUE RETURN END 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 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 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,RHOBAR,FRIC,TEMLIM, + OUTSCA,SIGHB) C C CALLS FLOW-LAW "DIAMND" (ONLY POINT IN PROGRAM) AND C COMPUTES SECANT EFFECTIVE VISCOSITY MATRIX ALPHA C IN 3X3 COMPONENT FORM FROM 2X2 PRINCIPAL AXIS FORM C AT EACH INTEGRATION POINT OF A LAYER. C (NOTE THAT ALPHA HAS DIMENSION OF VISCOSITY * THICKNESS) C C ALSO RECORDS OFFSET VALUES (TOFSET(3,7,NUMEL)) FOR NEXT ITERATION C CALCULATION OF TOFSET + ALPHA*E WILL GIVE MODEL DEFORMATIONAL C (DEVIATORIC) STRESS INTEGRALS C LOGICAL MANTLE DIMENSION ACREEP(3),ALPHA(3,3,7,NUMEL),BCREEP(3),CCREEP(3), + CONINT(7,NUMEL),DCREEP(3),ECREEP(3), + ERATE(4,7,NUMEL),FRIC(2),GEOTH(4,7,NUMEL), + OUTSCA(7,NUMEL),RHOBAR(2),SIGHB(2,7,NUMEL), + TAUMAT(3,7,NUMEL), + TEMLIM(2),THIK(7,NUMEL),TOFSET(3,7,NUMEL) SQRT2(X)=SQRT(MAX(X,1.E-50)) C IF (MANTLE) THEN FR=FRIC(2) RHO=RHOBAR(2) ELSE FR=FRIC(1) RHO=RHOBAR(1) ENDIF SCOREC=0. SCORED=0. DENOMV=0. DENOMF=0. EBASE=(RHO*G*ONEKM*0.001)/VISMAX STFRIC=SIN(ATAN(FR)) DO 1000 M=1,7 DO 900 I=1,NUMEL CTAMIP=OUTSCA(M,I) SIGHBI=SQRT2(SIGHB(1,M,I)**2+SIGHB(2,M,I)**2) DELP2=0.25*(TAUMAT(1,M,I)+TAUMAT(2,M,I))**2 SHEAR2=TAUMAT(3,M,I)**2+0.25* + (TAUMAT(1,M,I)-TAUMAT(2,M,I))**2 DENOMV=DENOMV+MAX(DELP2,SHEAR2) THICK=THIK(M,I) EXX=ERATE(1,M,I) EYY=ERATE(2,M,I) EXY=ERATE(3,M,I) IF(ABS(EXX-EYY).LT.EBASE) EXX=EYY-EBASE DIVER=EXX+EYY SHEAR=SQRT(EXY**2+0.25*(EXX-EYY)**2) E1=0.5*DIVER-SHEAR E2=0.5*DIVER+SHEAR ANGLE=ATAN2F(EXY,0.5*(EXX-EYY)) CALL DIAMND (I,M,EXX,EYY,EXY,E1,E2,TXX,TYY,TXY, + RADT,IREGON,DT1DE1,DT1DE2,DT2DE1,DT2DE2, + GEOTH,NUMEL,VISMAX,THICK,TEMLIM, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,RHOBAR,STFRIC,CTAMIP, + CONINT,SIGHBI) DENOMF=DENOMF+MAX(RADT**2,0.25*(TXX+TYY)**2) DXX=TAUMAT(1,M,I)-TXX DYY=TAUMAT(2,M,I)-TYY DXY=TAUMAT(3,M,I)-TXY DELP2=0.25*(DXX+DYY)**2 SHEAR2=.25*(DXX-DYY)**2+DXY**2 SCOREC=MAX(SCOREC,DELP2,SHEAR2) SCORED=SCORED+MAX(DELP2,SHEAR2) DE1DEX=0.5-(EXX-EYY)/(4.*SHEAR) DE1DEY=0.5+(EXX-EYY)/(4.*SHEAR) DE1DES= -EXY/SHEAR DE2DEX=DE1DEY DE2DEY=DE1DEX DE2DES= -DE1DES U=2.*EXY/(EXX-EYY) TERM=1./(1.+U**2) DANDEX= -TERM*U/(EXX-EYY) DANDEY= -DANDEX DANDES=TERM*2./(EXX-EYY) DTXDT1=0.5*(1.-COS(ANGLE)) DTXDT2=0.5*(1.+COS(ANGLE)) DTXDAN= -TXY DTYDT1=DTXDT2 DTYDT2=DTXDT1 DTYDAN=TXY DTSDT1= -0.5*SIN(ANGLE) DTSDT2= -DTSDT1 DTSDAN=RADT*COS(ANGLE) C FIRST SUBSCRIPT OF ALPHA REFERS TO STRESS (1:TXX,2:TYY,3:TXY) C SECOND SUBSCRIPT OF ALPHA REFERS TO STRAIN (1:EXX,2:EYY,3:EXY) DTXDE1=DTXDT1*DT1DE1+DTXDT2*DT2DE1 DTXDE2=DTXDT1*DT1DE2+DTXDT2*DT2DE2 ALPHA(1,1,M,I)= + DTXDE1*DE1DEX+DTXDE2*DE2DEX+DTXDAN*DANDEX ALPHA(1,2,M,I)= + DTXDE1*DE1DEY+DTXDE2*DE2DEY+DTXDAN*DANDEY ALPHA(1,3,M,I)= + DTXDE1*DE1DES+DTXDE2*DE2DES+DTXDAN*DANDES DTYDE1=DTYDT1*DT1DE1+DTYDT2*DT2DE1 DTYDE2=DTYDT1*DT1DE2+DTYDT2*DT2DE2 ALPHA(2,1,M,I)= + DTYDE1*DE1DEX+DTYDE2*DE2DEX+DTYDAN*DANDEX ALPHA(2,2,M,I)= + DTYDE1*DE1DEY+DTYDE2*DE2DEY+DTYDAN*DANDEY ALPHA(2,3,M,I)= + DTYDE1*DE1DES+DTYDE2*DE2DES+DTYDAN*DANDES DTSDE1=DTSDT1*DT1DE1+DTSDT2*DT2DE1 DTSDE2=DTSDT1*DT1DE2+DTSDT2*DT2DE2 ALPHA(3,1,M,I)= + DTSDE1*DE1DEX+DTSDE2*DE2DEX+DTSDAN*DANDEX ALPHA(3,2,M,I)= + DTSDE1*DE1DEY+DTSDE2*DE2DEY+DTSDAN*DANDEY ALPHA(3,3,M,I)= + DTSDE1*DE1DES+DTSDE2*DE2DES+DTSDAN*DANDES TOFSET(1,M,I)=TXX-ALPHA(1,1,M,I)*EXX + -ALPHA(1,2,M,I)*EYY + -ALPHA(1,3,M,I)*EXY TOFSET(2,M,I)=TYY-ALPHA(2,1,M,I)*EXX + -ALPHA(2,2,M,I)*EYY + -ALPHA(2,3,M,I)*EXY TOFSET(3,M,I)=TXY-ALPHA(3,1,M,I)*EXX + -ALPHA(3,2,M,I)*EYY + -ALPHA(3,3,M,I)*EXY 900 CONTINUE 1000 CONTINUE SCOREC=SQRT(SCOREC) SCORED=SQRT(SCORED/MAX(DENOMV,DENOMF)) RETURN END C C C SUBROUTINE DIAMND(I,M,EXX,EYY,EXY,E1,E2,TXX,TYY,TXY, + RADT,IREGON,DT1DE1,DT1DE2,DT2DE1,DT2DE2, + GEOTH,NUMEL,VISMAX,THICK,TEMLIM, + ACREEP,BCREEP,CCREEP,DCREEP,ECREEP,ONEKM, + MANTLE,G,RHOH2O,BIOT,RHOBAR,STFRIC,CTAMIP, + CONINT,SIGHBI) C C CALCULATES VERTICAL INTEGRAL OF (LOCAL) DEFORMATIONAL (DEVIATORIC) C STRESS COMPONENTS TXX, TYY, TXY FROM STRAIN-RATE COMPONENTS C C ALSO REPORTS TACTICAL CHOICES OF PARTIAL DERIVITIVES: C DT1DE1, DT1DE2, DT2DE1, AND DT2DE2 C IN PRINCIPAL-AXIS FORM. C 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),RHOBAR(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*(RHOBAR(1)-RHOH2O*BIOT) ZABS=Z+CRUST DPEDZ=G*(RHOBAR(2)-RHOH2O*BIOT) TLIM=TEMLIM(2) ILAYER=3 ELSE PE0=0. ZABS=Z DPEDZ=G*(RHOBAR(1)-RHOH2O*BIOT) TLIM=TEMLIM(1) ILAYER=1 ENDIF EZZ=-EXX-EYY SECINV=E1*E2 + E1*EZZ + E2*EZZ DEFORM=2.*SQRT(ABS(SECINV)) EN=DEFORM**ECREEP(ILAYER) ANGLE=ATAN2F(E2,E1)-0.7854 FACTOR=1./(1.+STFRIC*COS(ANGLE)) C C FIND BRITTLE/DUCTILE TRANSITION C DO 100 NITER=1,15 T=TEMP(Z,M,I) ZP=Z+ONEKM TP=TEMP(ZP,M,I) DTDZ=MAX((TP-T),1.)/ONEKM SF=STFRIC*(PE0+DPEDZ*Z)*FACTOR SF=MIN(SF,DCREEP(ILAYER)) TEMPT=1./( LOG(SF/(ACREEP(ILAYER)*EN))/ + (BCREEP(ILAYER)+CCREEP(ILAYER)*ZABS) ) DELZ=(TEMPT-T)/DTDZ IF (ABS(DELZ).LT.(0.03*ONEKM)) GO TO 101 DELZ=DELZ*MIN(1.,0.10*THICK/ABS(DELZ)) Z=Z+DELZ ZABS=ZABS+DELZ IF (Z.LE.0. .OR. Z.GE. THICK) GO TO 101 100 CONTINUE IF ((TEMPT-T).GT.10.) Z=THICK 101 Z=MAX(Z,0.) Z=MIN(Z,THICK) C C DETERMINE FRICTIONAL AND PLASTIC RESISTANCES C SFMIN=PE0*STFRIC*FACTOR SFMAX=(PE0+Z*DPEDZ)*STFRIC*FACTOR IF (SFMAX.LE.DCREEP(ILAYER).OR.Z.EQ.0.) THEN CONST=Z*(SFMAX+SFMIN)/2. PLAST=0. ELSE IF (SFMIN.GE.DCREEP(ILAYER)) THEN PLAST=Z*DCREEP(ILAYER) CONST=0. ELSE ZT=Z*(DCREEP(ILAYER)-SFMIN)/(SFMAX-SFMIN) CONST=0.5*ZT*(SFMIN+DCREEP(ILAYER)) PLAST=(Z-ZT)*DCREEP(ILAYER) ENDIF ENDIF C C FIND REFERENCE LEVEL TO WHICH NODAL VELOCITIES REFER: C IN CRUST, THIS IS ALWAYS THE SURFACE, C IN MANTLE, IT IS THE STRONGEST LEVEL. C IF (MANTLE) THEN ZBEAM=THICK STRMAX=0.0 DO 110 K=0,10,1 ZP=(THICK*K)/10 ZPABS=ZP+CRUST TP=TEMP(ZP,M,I) SCP=ACREEP(3)*EN* + EXP((BCREEP(3)+CCREEP(3)*ZPABS)/TP) SF=STFRIC*(PE0+DPEDZ*ZP)*FACTOR SCP=MIN(SCP,DCREEP(3),SF) IF (SCP.GE.STRMAX) THEN ZBEAM=ZP STRMAX=SCP ENDIF 110 CONTINUE ELSE ZBEAM=0.0 ENDIF C C INTEGRATE CREEP RESISTANCE C VAR=0. IF (Z.LT.THICK) THEN T=TEMP(Z,M,I) ZABS=Z IF (MANTLE) ZABS=Z+CRUST TOPSC=ACREEP(ILAYER)*EN* + EXP((BCREEP(ILAYER)+CCREEP(ILAYER)*ZABS)/T) OLDSC=TOPSC IBASE=THICK/ONEKM DO 120 JITER=1,IBASE ZP=Z+ONEKM ZPABS=ZABS+ONEKM IF (MANTLE) THEN IL=3 ELSE IF (ZPABS.GT.CONINT(M,I)) THEN IL=2 ELSE IL=1 ENDIF ENDIF TP=TEMP(ZP,M,I) SCP=ACREEP(IL)*EN* + EXP((BCREEP(IL)+CCREEP(IL)*ZPABS)/TP) SF=STFRIC*(PE0+DPEDZ*ZP)*FACTOR SCP=MIN(SCP,DCREEP(IL),SF) C NOTE: INTEGRAL STOPS WHEN PASSING THROUGH A DETACHMENT (WHERE C STRAIN-RATES WOULD DIFFER FROM SURFACE VALUES) IF (ZP.GT.ZBEAM.AND.SCP.LE.SIGHBI) GO TO 122 VAR=VAR+ONEKM*0.5*(OLDSC+SCP) IF (ZP.GE.THICK) GO TO 121 Z=ZP ZABS=ZPABS OLDSC=SCP 120 CONTINUE 121 VAR=VAR+(THICK-ZP)*SCP 122 CONTINUE ENDIF VIST=VAR/DEFORM C C MORE PRECISE TREATMENT OF FRICTIONAL RESISTANCE C IF ((CONST+PLAST).GT.0.) THEN CONST=CONST/(STFRIC*FACTOR) RATIO=(1.+STFRIC)/(1.-STFRIC) DTFEXT=CONST*(1.-1./RATIO) DTFCOM=CONST*(1.-RATIO) DT1(1)=DTFEXT+2.*PLAST DT2(1)=DTFEXT+2.*PLAST DT1(2)=0. DT2(2)=DTFEXT+2.*PLAST DT1(3)=DTFCOM-2.*PLAST DT2(3)=0. DT1(4)=DTFCOM-2.*PLAST DT2(4)=DTFCOM-2.*PLAST DO 220 K=1,4 DTF1(K)=DT1(K) DTF2(K)=DT2(K) DO 210 NITER=1,3 ETALPH(K)=DT1(K)/(2.*VISMAX*THICK) ETBETA(K)=DT2(K)/(2.*VISMAX*THICK) ET2(K)=(2.*ETBETA(K)-ETALPH(K))/3. ET1(K)=ETBETA(K)-2.*ET2(K) ETZ= -ET1(K) -ET2(K) SINK=ET1(K)*ET2(K) + ET1(K)*ETZ + ET2(K)*ETZ DEFNK=2.*SQRT(ABS(SINK)) VISP=VIST*(DEFNK/DEFORM)**(ECREEP(ILAYER)-1.) DT1(K)=DTF1(K)+2.*VISP*ETALPH(K) DT2(K)=DTF2(K)+2.*VISP*ETBETA(K) 210 CONTINUE ETALPH(K)=DT1(K)/(2.*VISMAX*THICK) ETBETA(K)=DT2(K)/(2.*VISMAX*THICK) ET2(K)=(2.*ETBETA(K)-ETALPH(K))/3. ET1(K)=ETBETA(K)-2.*ET2(K) 220 CONTINUE FRACZ=(ET1(2)+ET2(2))/((ET1(2)+ET2(2))-(ET1(3)+ET2(3))) SSERR=FRACZ*(DTF1(3)+DTF2(3))+(1.-FRACZ)*(DTF1(2)+DTF2(2)) SLOPE=(DTF1(2)+DTF2(2)-DTF1(3)-DTF2(3)) / + (ET1(2) +ET2(2) -ET1(3) -ET2(3) ) EMOVE=0.5*SSERR/SLOPE ET1(2)=ET1(2)+EMOVE ET2(2)=ET2(2)+EMOVE ET1(3)=ET1(3)+EMOVE ET2(3)=ET2(3)+EMOVE IF(E1.LT.ET1(1)) GO TO 230 IREGON=1 C DOUBLE NORMAL-FAULT CONJUGATE SETS T1=DTF1(1) + +2.*VIST*(2.*E1+E2) T2=DTF2(1) + +2.*VIST*(2.*E2+E1) DT1DE1=DTF1(1)/(2.*E1)+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=DTF2(1)/(2.*E2)+4.*VIST GO TO 290 230 IF(E1.LT.ET1(2)) GO TO 240 FRAC=(ET1(1)-E1)/(ET1(1)-ET1(2)) E2LIM=ET2(1)+(ET2(2)-ET2(1))*FRAC IF(E2.LT.E2LIM) GO TO 235 IREGON=2 C SINGLE NORMAL FAULT SET T1=FRAC*DTF1(2)+(1.-FRAC)*DTF1(1) + +2.*VIST*(2.*E1+E2) T2=FRAC*DTF2(2)+(1.-FRAC)*DTF2(1) + +2.*VIST*(2.*E2+E1) DT1DE1=4.*VISMAX*THICK DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=T2/E2 GO TO 290 235 IREGON=0 C PURELY VISCOUS RANGE T1=2.*VISMAX*(2.*E1+E2)*THICK T2=2.*VISMAX*(2.*E2+E1)*THICK DT1DE1=4.*VISMAX*THICK DT1DE2=2.*VISMAX*THICK DT2DE1=DT1DE2 DT2DE2=DT1DE1 GO TO 290 240 FRAC=((ET1(2)+ET2(2))-(E1+E2))/((ET1(2)+ET2(2))- 1 (ET1(3)+ET2(3))) IF(FRAC.GT.0.) GO TO 250 IREGON=3 C NORMAL + STRIKE-SLIP SETS T1=DTF1(2) + +2.*VIST*(2.*E1+E2) T2=DTF2(2) + +2.*VIST*(2.*E2+E1) IF (E1.LE.-0.5*E2) THEN ESUM=E1+E2 EDIF=E1-E2 TSUM=T1+T2 TDIF=T1-T2 DT1DE1=0.5*(TSUM/ESUM+TDIF/EDIF) DT1DE2=0.5*(TSUM/ESUM-TDIF/EDIF) DT2DE1=DT1DE2 DT2DE2=DT1DE1 ELSE DT1DE1=-0.5*DTF1(1)/E1+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=T2/E2 ENDIF GO TO 290 250 IF(FRAC.GT.1.) GO TO 260 E2LIM=ET2(2)+(ET2(3)-ET2(2))*FRAC IF(E2.LT.E2LIM) GO TO 235 IREGON=4 C CONJUGATE STRIKE-SLIP SET TF1=FRAC*DTF1(3)+(1.-FRAC)*DTF1(2) T1=TF1+2.*VIST*(2.*E1+E2) TF2=FRAC*DTF2(3)+(1.-FRAC)*DTF2(2) T2=TF2+2.*VIST*(2.*E2+E1) Q=((DTF1(2)-DTF2(2))-(DTF1(3)-DTF2(3))) / + ((ET1 (2)+ET2 (2))-(ET1 (3)+ET2 (3))) DT1DE1=3.*VISMAX*THICK+0.5*(T1-T2)/(E1-E2)+0.5*Q DT1DE2=3.*VISMAX*THICK-0.5*(T1-T2)/(E1-E2)+0.5*Q DT2DE1=DT1DE2-Q DT2DE2=DT1DE1-Q GO TO 290 260 IF(E2.LT.ET2(3)) GO TO 270 IREGON=5 C STRIKE-SLIP + THRUST SETS T1=DTF1(3) + +2.*VIST*(2.*E1+E2) T2=DTF2(3) + +2.*VIST*(2.*E2+E1) IF (E2.GE.-0.5*E1) THEN ESUM=E1+E2 EDIF=E1-E2 TSUM=T1+T2 TDIF=T1-T2 DT1DE1=0.5*(TSUM/ESUM+TDIF/EDIF) DT1DE2=0.5*(TSUM/ESUM-TDIF/EDIF) DT2DE1=DT1DE2 DT2DE2=DT1DE1 ELSE DT1DE1=T1/E1 DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=-0.5*DTF2(4)/E2+4.*VIST ENDIF GO TO 290 270 IF(E2.LT.ET2(4)) GO TO 275 FRAC=(ET2(3)-E2)/(ET2(3)-ET2(4)) E1LIM=ET1(3)+(ET1(4)-ET1(3))*FRAC IF(E1.GT.E1LIM) GO TO 235 IREGON=6 C ONE CONJUGATE THRUST SET T1=FRAC*DTF1(4)+(1.-FRAC)*DTF1(3) + +2.*VIST*(2.*E1+E2) T2=FRAC*DTF2(4)+(1.-FRAC)*DTF2(3) + +2.*VIST*(2.*E2+E1) DT1DE1=T1/E1 DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=4.*VISMAX*THICK GO TO 290 275 IREGON=7 C DOUBLE THRUST SETS T1=DTF1(4) + +2.*VIST*(2.*E1+E2) T2=DTF2(4) + +2.*VIST*(2.*E2+E1) DT1DE1=DTF1(4)/(2.*E1)+4.*VIST DT1DE2=2.*VIST DT2DE1=DT1DE2 DT2DE2=DTF2(4)/(2.*E2)+4.*VIST 290 CONTINUE ELSE VISLIM=VISMAX*THICK VIS=MIN(VIST,VISLIM) IREGON=8 IF (VIS.LT.VIST) IREGON=0 T1=2.*VIS*(2.*E1+E2) T2=2.*VIS*(2.*E2+E1) DT1DE1=4.*VIS DT1DE2=2.*VIS DT2DE1=DT1DE2 DT2DE2=DT1DE1 ENDIF RADT=0.5*(T2-T1) IF((E1-E2).NE.0.) THEN C=(T2-T1)/(E2-E1) ELSE C=0. ENDIF TXX=.5*(C*(EXX-EYY)+T1+T2) TYY=T1+T2-TXX TXY=C*EXY RETURN END 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,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,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, 9 CINT,FROMWC,FROMWM,IBELOW,WANDES,CONINT,CONNOD B ,TSURF,PUSHUP,IPENCT,IPENST,IPENLB,COLOR) C C PRINTS MAPS OF IMPORTANT QUANTITIES ON LINE PRINTER. C PLOTS SHOW VALUES AT INTEGRATION POINTS, WITH LOCATION C FUDGED TO NEAREST POINT IN RECTANGULAR PRINTING GRIDS. C WHEN TWO OR MORE POINTS SHARE A PRINT GRID SQUARE, C SCALAR VALUES OR SIMPLE VECTORS ARE AVERAGED ACCORDING TO C THEIR GAUSSIAN WEIGHTS; BUT "VECTORS" REPRESENTING PRINCIPAL C AXES OF SECOND-RANK TENSORS ARE JUST OVERLAID, WITH C PRIORITY ACCORDING TO GAUSSIAN WEIGHT. C SCALARS ARE REPRESENTED BY DIGITS 0,1,2,3,4,5,6,7,8,9,*. C VECTORS (AND PRINCIPAL AXES OF TENSORS, TREATED AS VECTORS) C ARE REPRESENTED BY NUMERICAL DIGIT 0-* AND A LETTER A-L C WHICH REPRESENTS DIRECTION ACCORDING TO CODE A=1 O'CLOCK, C B=2 O'CLOCK....L=12 O'CLOCK. C IN THE CASE OF PRINCIPAL AXIS "VECTORS", THE CONVENTION IS C THAT DIRECTIONS A-F MEAN NEGATIVE PRINCIPAL VALUES, C AND DIRECTIONS G-L MEAN POSITIVE VALUES. C C BEFORE USE, FILL IN THE X (HORIZONTAL) AND Y (VERTICAL) C INCREMENT OF THE PRINTER (IN INCHES): DXPR & DYPR C AND ALSO THE EFFECTIVE NUMBER OF LINES IN A PAGE: NLINES C IN THE DATA STATEMENT BELOW. COLUMNS NPCOL WILL USUALLY BE 132; C THE INVISIBLE FIRST POSITION FOR CARRIAGE CONTROL IS NOT COUNTED. C C C FOLLOWING LINE SETS MAXIMUM NUMBER OF ELEMENTS: PARAMETER (N50=280) C FOLLOWING LINE SETS MAXIMUM NUMBER OF NODES: PARAMETER (N121=609) C FOLLOWING LINE SETS MAXIMUM NUMBER OF POINTS IN STATELINE MAPS: PARAMETER (NSTATE=2000) C CHARACTER*1 BLANK,BOARD1(59,63),BOARD2(59,63),CITY CHARACTER*80 TITLE CHARACTER*42 TEXT,VUNITS LOGICAL ALLPOS,AVERAG,COLOR,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),NODES(6,0:NUMEL), 1 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 C EXTRA STORAGE, FOR THIS PROGRAM ONLY, TO HOLD MAP POSITIONS C CONVERTED TO PLOT INCHES: DIMENSION XNODCP(N121),XNODMP(N121), + YNODCP(N121),YNODMP(N121), + XIPCP(7,N50),XIPMP(7,N50), + YIPCP(7,N50),YIPMP(7,N50), + XSTP(NSTATE),YSTP(NSTATE) 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)/39/ DATA VUNITS(21)/'COMMON LOG (E1 OR E3) '/ DATA NVUCHR(21)/21/ DATA TEXT(22)/'CRUST: NET CLOCKWISE ROTATION '/ DATA NVCHAR(22)/29/ DATA VUNITS(22)/'DEGREES '/ DATA NVUCHR(22)/7/ DATA TEXT(23)/'THICKNESS OF CRUST ABOVE CONRAD '/ DATA NVCHAR(23)/31/ DATA VUNITS(23)/'CM '/ DATA NVUCHR(23)/2/ DATA TEXT(24)/'THICKNESS OF CRUST BELOW CONRAD '/ DATA NVCHAR(24)/31/ DATA VUNITS(24)/'CM '/ DATA NVUCHR(24)/2/ C C STATEMENT FUNCTIONS FOR PRINTER-PLOTTING: IROW(Y)=MAX(1,MIN(KRL,INT(ROWFAC*Y+ROWCON+1.5))) JCOL(X)=MAX(1,MIN(KCL,INT(COLFAC*X+COLCON+1.5))) C C C STATEMENT FUNCTIONS FOR CALCOMP PLOTTING IN INCHES: XCAL(X)=0.2+(X-XMIN)/SCALE YCAL(Y)=4.25+(Y-0.5*(YMIN+YMAX))/SCALE C C****************************************************** C CM-TO-INCHES CONVERSION (MAY HAVE TO BE CHANGED IF C A LATER USER WORKS IN SI UNITS, WITH METERS!) SCALE=2.54*SCALEC C****************************************************** C 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 ROWCON= 0.5*((0.0-ROWFAC*YMAX)+(KRL-1.-ROWFAC*YMIN)) COLFAC= 1./DX COLCON= 0.5*((0.0-COLFAC*XMIN)+(KCL-1.-COLFAC*XMAX)) IORIGI=IROW(0.) JORIGI=JCOL(0.) ENDIF IF (NUMNOD.GT.N121.OR.NUMEL.GT.N50.OR.NXYST.GT.NSTATE) THEN WRITE(6,11) 11 FORMAT(' MORE WORKING STORAGE REQUIRED IN SUBR. REPORT') STOP ENDIF DO 12 I=1,NUMNOD XNODCP(I)=XCAL(XNODC(I)) XNODMP(I)=XCAL(XNODM(I)) YNODCP(I)=YCAL(YNODC(I)) YNODMP(I)=YCAL(YNODM(I)) 12 CONTINUE DO 14 M=1,7 DO 13 I=1,NUMEL XIPCP(M,I)=XCAL(XIPC(M,I)) XIPMP(M,I)=XCAL(XIPM(M,I)) YIPCP(M,I)=YCAL(YIPC(M,I)) YIPMP(M,I)=YCAL(YIPM(M,I)) 13 CONTINUE 14 CONTINUE DO 16 I=1,NXYST XSTP(I)=XCAL(XST(I)) YSTP(I)=YCAL(YST(I)) 16 CONTINUE 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,XNODMP,YNODMP,TITLE,TEXT,1,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,SIGHBM,RMSVEC,XIPMP,YIPMP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,2,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,SIGHC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODMP,YNODMP,TITLE,TEXT,3,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPMP,YIPMP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,4,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODMP,YNODMP,TITLE,TEXT,5,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPMP,YIPMP, + DOFLTS,ERATEM,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,6,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATEC,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODMP,YNODMP,TITLE,TEXT,7,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPMP,YIPMP, + DOFLTS,ERATEM,TAUMTM,TAUZZM, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,8,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATEC,TAUMTC,TAUZZC, + IPENCT,IPENST,IPENLB,COLOR) 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,9, + NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE,T2MA, + XNODMP,XSTP,YNODMP,YSTP, + IPENCT,IPENST,IPENLB,COLOR) ENDIF CALL NET + (BOARD2,XNODC,YNODC, + NUMNOD,NODES,NUMEL,ROWFAC,ROWCON, + COLFAC,COLCON) IF (DOPLOT(10)) THEN CALL ETCH (DRAWST,10, + NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE,T2MA, + XNODCP,XSTP,YNODCP,YSTP, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODMP,YNODMP,TITLE,TEXT,11,T2MA, + WM,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPMP,YIPMP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,12,T2MA, + WC,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODMP,YNODMP,TITLE,TEXT,13,T2MA, + THNKM,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPMP,YIPMP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,14,T2MA, + THNKC,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODMP,YNODMP,TITLE,TEXT,15,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPMP,YIPMP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,16,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,17,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,18,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,19,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,20,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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(OUTSCA(M,I)) 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,XNODCP,YNODCP,TITLE,TEXT,21,T2MA, + CONDNS,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATEC,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,22,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,23,T2MA, + CONNOD,DFCON1,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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,XNODCP,YNODCP,TITLE,TEXT,24,T2MA, + CONDNS,DFCON2,NUMNOD,NUMEL,ALLPOS, + STATES, + DRAWST,NXYST,XSTP,YSTP, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIPCP,YIPCP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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 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, + STATES, + DRAWST,NXYST,XST,YST, + NVCHAR,NVUCHR,VUNITS, + FBLAND,LOWBLU, + DOAROW,DOAXES,OUTVEC,RMSVEC,XIP,YIP, + DOFLTS,ERATE,TAUMT,TAUZZ, + IPENCT,IPENST,IPENLB,COLOR) 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 PARAMETER (NCOLOR=12) CHARACTER*80 TITLE,TITLE2 CHARACTER*42 TEXT,TTEXT,VUNITS CHARACTER*8 FILNAM CHARACTER*5 TMYCHR,CLCHR,ASCII EXTERNAL ASCII LOGICAL ALLPOS,COLOR,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) DIMENSION IFILL1(16),IFILL2(16),IFILL3(16),IFILL4(16), + IFILL5(16),IFILL6(16),IFILL7(16),IFILL8(16), + IFILL9(16),IFILLA(16),IFILLB(16),IFILLC(16) DIMENSION IARRAY(1) C C SELECT COLORS: 9 = WHITE, 12 C 171 = PINK, 11 C 175 = RED, 10 C 178 = DARK RED, 9 C 144 = ORANGE, 8 C 130 = YELLOW, 7 C 123 = YELLOW/GREEN, 6 C 87 = GREEN 5 C 85 = TURQUOISE, 4 C 2 = BLUE, 3 ___________ C 29 = DARK BLUE, 2 __CINT___ C 1 = BLACK. 1 C DATA ICOLOR/1,29,2,85,87,123,130,144,178,175,171,9/ C C SELECT SHADING PATTERNS: C 12 = * ] 135/256 (DARKEST) C 11 = # ] 112/256 C 10 = H ] 46/256 C 9 = / / ] 32/256 C 8 = = ] 32/256 C 7 = / ] 16/256 C 6 = .] ] 16/256 C 5 = :.: ] 12/256 C 4 = : : ] 8/256 C 3 = : ] 6/256 ______________ C 2 = . ] 4/256 __CINT________ C 1 = ] 0/256 (WHITE) C DATA IFILL1 /Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000, + Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000/ DATA IFILL2 /Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0180, + Z0180,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000/ DATA IFILL3 /Z0000,Z0000,Z0000,Z1800,Z1000,Z0000,Z0000,Z0000, + Z0000,Z0000,Z0000,Z0008,Z0018,Z0000,Z0000,Z0000/ DATA IFILL4 /Z0000,Z0000,Z0000,Z1818,Z0000,Z0000,Z0000,Z0000, + Z0000,Z0000,Z0000,Z1818,Z0000,Z0000,Z0000,Z0000/ DATA IFILL5 /Z0180,Z0000,Z0000,Z8001,Z8001,Z0000,Z0000,Z0000, + Z0000,Z0000,Z0000,Z8001,Z8001,Z0000,Z0000,Z0180/ DATA IFILL6 /Z0002,Z0002,Z0002,Z0002,Z0002,Z0002,Z0002,Z0002, + Z0002,Z0002,Z0002,Z0002,Z0002,Z0002,Z0002,Z0002/ DATA IFILL7 /Z8000,Z4000,Z2000,Z1000,Z0800,Z0400,Z0200,Z0100, + Z0080,Z0040,Z0020,Z0010,Z0008,Z0004,Z0002,Z0001/ DATA IFILL8 /Z0000,ZFFFF,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000, + Z0000,ZFFFF,Z0000,Z0000,Z0000,Z0000,Z0000,Z0000/ DATA IFILL9 /Z0101,Z0202,Z0404,Z0808,Z1010,Z2020,Z4040,Z8080, + Z0101,Z0202,Z0404,Z0808,Z1010,Z2020,Z4040,Z8080/ DATA IFILLA /ZFF01,Z0101,Z0101,Z0101,Z0101,Z0101,Z0101,Z0101, + Z01FF,Z0101,Z0101,Z0101,Z0101,Z0101,Z0101,Z0101/ DATA IFILLB /ZFFFF,Z8181,Z8181,Z8181,Z8181,Z8181,Z8181,ZFFFF, + ZFFFF,Z8181,Z8181,Z8181,Z8181,Z8181,Z8181,ZFFFF/ DATA IFILLC /ZFFFF,Z9248,Z9248,ZFFFF,Z9248,Z9248,ZFFFF,Z9248, + Z9248,ZFFFF,Z9248,Z9248,ZFFFF,Z9248,Z9248,Z9248/ C C INITIALIZE VERSATEC C IF (COLOR) CALL VPOPT(101,0,0.0,IERR) IARRAY(1)=7 CALL VPOPT(20,IARRAY,RARG,IER) CALL PLOTS(0,0,0) CALL PAPER (0.0,11.1,0.0,10.5) CALL SETFNT(18) IF (COLOR) THEN CALL TONFLG(1) ENDIF CALL DEFPEN(32,IPENST,20,5,5,5) CALL DEFPAT(1,IFILL1,16) CALL DEFPAT(2,IFILL2,16) CALL DEFPAT(3,IFILL3,16) CALL DEFPAT(4,IFILL4,16) CALL DEFPAT(5,IFILL5,16) CALL DEFPAT(6,IFILL6,16) CALL DEFPAT(7,IFILL7,16) CALL DEFPAT(8,IFILL8,16) CALL DEFPAT(9,IFILL9,16) CALL DEFPAT(10,IFILLA,16) CALL DEFPAT(11,IFILLB,16) CALL DEFPAT(12,IFILLC,16) 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********************************************************************** C C BEGIN SEGMENT 1 (CONTOURED ELEMENTS) C C RESERVE SPACE FOR TITLES AND COLOR BAR C CALL WINDOW(0.2,9.55,0.45,8.05) CALL VPORT (0.2,9.55,0.45,8.05) CALL CONTEL (NODES,XNOD,YNOD,FUNC,CINT,NUMNOD,NUMEL, + FMAX,FMIN,NCOLOR,ICOLOR,FMIDLE,IFLIP, + NBLUE,NYELOW,ALLPOS,COLOR,IPENCT) C C END SEGMENT OF COLORED ELEMENTS C C************************************************************* C C BEGIN SEGMENT 2 (VECTORS OR TENSOR SYMBOLS, OR DUMMY) C TENSORS INCLUDED WITH OTHER VARIABLES) C IF (DOAROW) THEN IF (COLOR) THEN CALL TONCLR(1) CALL PENCLR(IPENLB,1) ELSE CALL SETPAT(0) ENDIF CALL NEWPEN(IPENLB) CALL ARROW (NUMEL,OUTVEC,RMSVEC, + XIP,YIP,CINT,9.53,8.03) ELSE IF (DOAXES) THEN IF (COLOR) THEN CALL TONCLR(1) CALL PENCLR(IPENLB,1) ELSE CALL SETPAT(0) ENDIF CALL NEWPEN(IPENLB) CALL AXES (NUMEL,TAUMT,TAUZZ,RMSVEC,IPENLB, + XIP,YIP,CINT,9.53,8.03) ELSE IF (DOFLTS) THEN IF (COLOR) THEN CALL TONCLR(1) CALL PENCLR(IPENLB,1) ELSE CALL SETPAT(0) ENDIF CALL NEWPEN(IPENLB) CALL FAULTS (NUMEL,ERATE,RMSVEC, + XIP,YIP) ENDIF C C END SEGMENT C C******************************************************************* IF (STATES) THEN C C BEGIN SEGMENT FOR STATE LINES (3) C C USE BLACK PEN TO OVERWRITE OTHER COLORS C IF (COLOR) THEN CALL PENCLR(32,1) ENDIF C CALL NEWPEN(32) CALL USMAP (INPUT,DRAWST,NXYST,XST,YST) C C END SEGMENT WITH STATE LINES C ENDIF C**************************************************************** C C BEGIN SEGMENT 4 (COLOR BAR AND CONTOUR INTERVALS) C CALL NEWPEN(IPENLB) C C OPEN WINDOW TO ALLOW SPACE C CALL WINDOW(0.1,10.9,0.1,8.4) CALL VPORT (0.1,10.9,0.1,8.4) 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) HEIGHT=0.12 WIDTH=HEIGHT*0.87 C C SET LABEL ANGLE TO ZER0 (LIKE THIS) C SANGLE=0.0 C C ADD UNITS C WIDE=WIDTH*NVUCHR(JV) IF (WIDE.LE.0.25) THEN X=10.55-WIDE/2. ELSE X=10.8-WIDE ENDIF Y=YTOP+0.7*HEIGHT YOLD=Y YNEXT=Y-1.1*HEIGHT C C USE BLACK FOR CONTOUR LEVEL LABELS C IF (COLOR) THEN CALL PENCLR(IPENLB,1) CALL NEWPEN(IPENLB) ENDIF C CALL SYMBOL(X,Y,HEIGHT,VUNITS(JV),IDUMMY,SANGLE,NVUCHR(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) IF (COLOR) THEN CALL TONCLR(ICOLOR(N)) IF (N.EQ.NCOLOR) THEN CALL PENCLR(IPENLB,1) CALL NEWPEN(IPENLB) IBOX=1 ELSE IBOX=0 ENDIF ELSE CALL SETPAT(N) IBOX=1 ENDIF CALL RECT(10.3,10.8,YBOT+0.01,YTOP-0.01,IBOX) C C USE BLACK FOR CONTOUR LEVEL LABELS C IF (COLOR) THEN CALL PENCLR(IPENLB,1) CALL NEWPEN(IPENLB) ENDIF C ARG=1.001*FTOP/10.**CIPOW CLCHR=ASCII(1.001*FTOP/10.**CIPOW) X=10.3-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 SYMBOL(X,Y,HEIGHT,CLCHR,IDUMMY,SANGLE,NPRINT) ENDIF IF (I.EQ.NSTEPB) THEN CLCHR=ASCII(1.001*FBOT/10.**CIPOW) X=10.3-5.5*WIDTH Y=YBOT-0.5*HEIGHT IF (Y.LE.YNEXT) + CALL SYMBOL(X,Y,HEIGHT,CLCHR,IDUMMY,SANGLE,5) ENDIF 1050 CONTINUE C C ADD 10**N MULTIPLIER C IF (ABS(CIPOW).GT.0.1) THEN X=10.8-7.0*WIDTH Y=YBOT-2.0*HEIGHT CALL SYMBOL(X,Y,HEIGHT,'X 1O',IDUMMY,SANGLE,4) IF (ABS(CIPOW-1.).GT.0.1) THEN Y=YBOT-1.3*HEIGHT X=10.8-3.0*WIDTH CLCHR=ASCII(CIPOW) IF (CLCHR(1:1).EQ.' ') X=X-WIDTH IF (CLCHR(2:2).EQ.' ') X=X-WIDTH CALL SYMBOL(X,Y,HEIGHT,CLCHR,IDUMMY,SANGLE,3) ENDIF ENDIF C C END SEGMENT OF COLOR BAR C C******************************************************************* C C BEGIN SEGMENT 5 (TITLE + VARIABLE + TIME) C HEIGHT=0.15 WIDTH=HEIGHT*0.87 C C SET LABEL ANGLE TO ZER0 C SANGLE=0.0 C C USE BLACK FOR TITLES C IF (COLOR) THEN CALL PENCLR(IPENLB,1) CALL NEWPEN(IPENLB) ENDIF 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 SYMBOL(0.2,0.2,HEIGHT,TITLE2,IDUMMY,SANGLE,80) C C WRITE VARIABLE AND TIME IDENTIFIERS C CALL SYMBOL(0.2,8.15,HEIGHT,TEXT(JV),IDUMMY,SANGLE,NVCHAR(JV)) CALL SYMBOL(999.0,999.0,HEIGHT,' AT ',IDUMMY,SANGLE,4) TMYCHR=ASCII(T2MA) CALL SYMBOL(999.0,999.0,HEIGHT,TMYCHR,IDUMMY,SANGLE,5) CALL SYMBOL(999.0,999.0,HEIGHT,' MA (',IDUMMY,SANGLE,5) CALL EPOCH (IMPUT,T2MA,OUTPUT,NECHAR,TTEXT) CALL SYMBOL(999.0,999.0,HEIGHT,TTEXT,IDUMMY,SANGLE,NECHAR) CALL SYMBOL(999.0,999.0,HEIGHT,')',IDUMMY,SANGLE,1) C C END SEGMENT WITH TEXT LABELS C C**************************************************************** C C SHUT DOWN VERSATEC C CALL PLOT(11.0,0.0,999) C RETURN END C C C SUBROUTINE ETCH (DRAWST,JV, + NODES,NUMEL,NUMNOD,NVCHAR,NXYST, + STATES,TEXT,TITLE,T2MA, + XNOD,XST,YNOD,YST, + IPENCT,IPENST,IPENLB,COLOR) C C PLOTS THE FINITE ELEMENT GRID AND STATE OUTLINES. C LABELS WITH GRID LEVEL AND TIME ABOVE, MODEL TITLE BELOW. C CHARACTER*80 TITLE,TITLE2 CHARACTER*42 TEXT,TTEXT CHARACTER*8 FILNAM CHARACTER*5 TMYCHR,ASCII CHARACTER*1 ITEXT EXTERNAL ASCII LOGICAL COLOR,DRAWST,S4,S5,S6,STATES DIMENSION DRAWST(NXYST),IARRAY(1),IDSEG(1), + NODES(6,0:NUMEL),NVCHAR(24),TEXT(24), + XNOD(NUMNOD),YNOD(NUMNOD), + XST(NXYST),YST(NXYST) C C INITIALIZE VERSATEC C IF (COLOR) CALL VPOPT(101,0,0.0,IERR) IARRAY(1)=7 CALL VPOPT(20,IARRAY,RARG,IER) CALL PLOTS(0,0,0) CALL PAPER (0.0,11.1,0.0,10.5) CALL SETFNT(18) IF (COLOR) THEN CALL TONFLG(1) ENDIF CALL DEFPEN(32,IPENST,20,5,5,5) C C C********************************************************************** C C BEGIN SEGMENT 1 (FINITE ELEMENT GRID) C C RESERVE SPACE FOR TITLES CALL WINDOW(0.2,10.8,0.45,8.05) CALL VPORT (0.2,10.8,0.45,8.05) C C PLOT ALL ELEMENT SIDES (IN GREEN; MANY ARE DRAWN TWICE) C IF (COLOR) THEN CALL PENCLR(IPENCT,7) ENDIF CALL NEWPEN(IPENCT) 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 (IN RED, IF COLOR), BUT ONLY IF IPENLB.GT.1 C IF (IPENLB.GT.1) THEN IF (COLOR) THEN CALL PENCLR(IPENLB,6) ENDIF CALL NEWPEN(IPENLB) DO 20 I=1,NUMNOD CALL SYMBOL(XNOD(I),YNOD(I),0.08,ITEXT,1,0.0,-1) 20 CONTINUE ENDIF C C CLOSE SEGMENT OF FINITE ELEMENT GRID C C**************************************************************** IF (STATES) THEN C C BEGIN SEGMENT FOR STATE LINES (3) C C USE BLUE PEN C IF (COLOR) THEN CALL PENCLR(32,2) ENDIF C CALL NEWPEN(32) CALL USMAP (INPUT,DRAWST,NXYST,XST,YST) C C CLOSE SEGMENT WITH STATE LINES C ENDIF C**************************************************************** C C BEGIN SEGMENT 5 (TITLE + VARIABLE + TIME) C C OPEN UP WINDOW C CALL WINDOW(0.1,10.9,0.1,8.4) CALL VPORT (0.1,10.9,0.1,8.4) C CALL NEWPEN(IPENLB) HEIGHT=0.15 WIDTH=HEIGHT*0.87 C C SET LABEL ANGLE TO ZER0 (LIKE THIS) C SANGLE=0.0 C C USE BLACK FOR TEXT C IF (COLOR) THEN CALL PENCLR(IPENLB,1) ENDIF CALL NEWPEN(IPENLB) 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 SYMBOL(0.1,0.2,HEIGHT,TITLE2,IDUMMY,SANGLE,80) C C WRITE VARIABLE AND TIME IDENTIFIERS C CALL SYMBOL(0.20,8.15,HEIGHT,TEXT(JV),IDUMMY,SANGLE,NVCHAR(JV)) CALL SYMBOL(999.0,999.0,HEIGHT,' AT ',IDUMMY,SANGLE,4) TMYCHR=ASCII(T2MA) CALL SYMBOL(999.0,999.0,HEIGHT,TMYCHR,IDUMMY,SANGLE,5) CALL SYMBOL(999.0,999.0,HEIGHT,' MA (',IDUMMY,SANGLE,5) CALL EPOCH (IMPUT,T2MA,OUTPUT,NECHAR,TTEXT) CALL SYMBOL(999.0,999.0,HEIGHT,TTEXT,IDUMMY,SANGLE,NECHAR) CALL SYMBOL(999.0,999.0,HEIGHT,')',IDUMMY,SANGLE,1) C C CLOSE SEGMENT WITH TEXT LABELS C C**************************************************************** C C SHUT DOWN VERSATEC C CALL PLOT(11.0,0.0,999) C RETURN END C C C SUBROUTINE CONTEL (NODES,XNOD,YNOD,FUNC,DFCON,NUMNOD,NUMEL, + FGMAX,FGMIN,NCOLOR,ICOLOR,FMIDLE,IFLIP, + NBLUE,NYELOW,ALLPOS,COLOR,IPENCT) 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(MXAREA=10,NINLIN=130,NWORK=1300,NPOLYV=1000) LOGICAL ALLPOS,ANEDGE,BEGCON,BEGNXT,BITSEG,CENTER,CIRCLE, + COLOR,DASHED,DONE,ENDCON,FINISH,GONOUT, + HITLIM,INSIDE, + NEIGHB,SIDMAX,SIDMIN,SURROU, + THRU,Z C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ LOGICAL DUMPIT C (LEAVE IN THIS DEBUG CODE FOR A FEW YEARS MORE) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 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 C LOCAL STORAGE FOR OUTLINES OF COLORED AREAS: DIMENSION IPCLR(NPOLYV),NINARE(MXAREA), + XARRAY(NPOLYV),YARRAY(NPOLYV) 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 C C USE BLACK PEN OF WIDTH IPENCT UNLESS MODIFIED C IF (COLOR) THEN CALL PENCLR(IPENCT,1) LASTKO=1 ENDIF CALL NEWPEN(IPENCT) DO 9999 IEL=1,NUMEL C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ DUMPIT=.FALSE. C (LEAVE IN THIS DEBUG CODE FOR A FEW YEARS MORE) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C LOCAL INITIALIZATION (ONE ELEMENT) C NPS=0 ISPNUM=0 ISPLEN(0)=0 ISPPNT(0)=1 CENTER=.FALSE. TSIDE=1.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 C$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7771)IEL,(NODES(J,IEL),J=1,6), + (XN(J),J=1,6),(YN(J),J=1,6),(FN(J),J=1,6) 7771 FORMAT(/ / /' ========================================'/ + ' IEL=',I4/ + ' NODES =',6I10/ + ' XN =',1P,6E10.3/ + ' YN =', 6E10.3/ + ' FN =', 6E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ I1=IN(1) I2=IN(2) I3=IN(3) I4=IN(4) I5=IN(5) I6=IN(6) X1=XN(1) X2=XN(2) X3=XN(3) X4=XN(4) X5=XN(5) X6=XN(6) Y1=YN(1) Y2=YN(2) Y3=YN(3) Y4=YN(4) Y5=YN(5) Y6=YN(6) FMAX=MAX(FN(1),FN(2),FN(3),FN(4),FN(5),FN(6)) FMIN=MIN(FN(1),FN(2),FN(3),FN(4),FN(5),FN(6)) RANGE=MAX((FMAX-FMIN),DFCON) C C PREVENT DEGENERATE CASES WHERE NODES FALL EXACTLY ON CONTOURS C DO 10 J=1,6 I=FN(J)/DFCON IF ((I*DFCON).EQ.FN(J)) FN(J)=FN(J)+0.01*RANGE 10 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7772) + (FN(J),J=1,6) 7772 FORMAT(/ /' AFTER ADJUSTMENT TO PREVENT SINGULARITY:'/ + ' FN =',1P,6E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ F1=FN(1) F2=FN(2) F3=FN(3) F4=FN(4) F5=FN(5) F6=FN(6) C C*************************************************************** C C EXAMINE SIDES FOR EXTREMA AND MARK CONTOUR INTERSECTIONS C DO 100 MSIDE=1,3 N1=MSIDE N2=MOD(MSIDE,3)+1 SIDE=SQRT((XN(N1)-XN(N2))**2+(YN(N1)-YN(N2))**2) TSIDE=MIN(TSIDE,SIDE) NM=MSIDE+3 DFDS1= -3.*FN(N1)+4.*FN(NM)- FN(N2) DFDS2= FN(N1)-4.*FN(NM)+3.*FN(N2) D2FDS=4.*FN(N1)-8.*FN(NM)+4.*FN(N2) IF ((DFDS1*DFDS2.GE.0.).OR.(D2FDS.EQ.0.0)) THEN FMX=AMAX1(FN(N1),FN(N2)) FMN=AMIN1(FN(N1),FN(N2)) CALL DOSIDE (FMX,FMN,DFCON,FN,N1,N2,NM,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=1 WRITE(6,401)IEL,NCRASH GO TO 9999 ENDIF ELSE SEXT= -DFDS1/D2FDS FEXT=FN(N1)+ + DFDS1*SEXT+ + 0.5*D2FDS*SEXT**2 FMAX=MAX(FMAX,FEXT) FMIN=MIN(FMIN,FEXT) C C FIND INTERSECTIONS OF CONTOURS WITH SIDE CONTAINING EXTREMUM C FMX=AMAX1(FN(N1),FEXT) FMN=AMIN1(FN(N1),FEXT) CALL DOPART (FEXT,FMX,FMN,DFCON,FN, + N1,N2,NM,0.,SEXT,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=2 WRITE(6,401)IEL,NCRASH GO TO 9999 ENDIF FMX=AMAX1(FEXT,FN(N2)) FMN=AMIN1(FEXT,FN(N2)) CALL DOPART (FEXT,FMX,FMN,DFCON,FN, + N1,N2,NM,SEXT,1.,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=3 WRITE(6,401)IEL,NCRASH GO TO 9999 ENDIF ENDIF 100 CONTINUE RTESTR=TSIDE*DSTEP C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7773) 7773 FORMAT(/ /' CONTOUR POINTS ON SIDES, BEFORE SORTING:'/) DO 101 INPS=1,NPS XQ=PHIVAL(PS(1,INPS),PS(2,INPS),PS(3,INPS),X1,X2,X3,X4,X5,X6) YQ=PHIVAL(PS(1,INPS),PS(2,INPS),PS(3,INPS),Y1,Y2,Y3,Y4,Y5,Y6) WRITE(6,7774)INPS,(PS(J,INPS),J=1,4),XQ,YQ 7774 FORMAT(' ',I10,0P,3F10.5,1P,3E10.3) 101 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C*************************************************************** C C SORT THE POINTS FOUND BY CLOCKWISE PARAMETER S = PS(5,) C DO 200 INPS=1,NPS S1=PS(1,INPS) S2=PS(2,INPS) S3=PS(3,INPS) F=PS(4,INPS) IF (F.GE.0.) THEN IC=F/DFCON+0.1 ELSE IT= -F/DFCON+0.1 IC= -IT ENDIF IHIC=MAX(IHIC,IC) ILOC=MIN(ILOC,IC) IF (S3.EQ.0.) THEN SN=S2 ELSE IF (S1.EQ.0.) THEN SN=1.+S3 ELSE SN=2.+S1 ENDIF PS(5,INPS)=SN 200 CONTINUE SNOW= -0.1 DO 300 INPS=1,NPS LOWEST=3.1 JMOVE=INPS DO 250 JNPS=1,NPS IF (PS(5,JNPS).GT.SNOW) THEN IF (PS(5,JNPS).LT.LOWEST) THEN LOWEST=PS(5,JNPS) JMOVE=JNPS ENDIF ENDIF 250 CONTINUE DO 270 K=1,5 PS2(K,INPS)=PS(K,JMOVE) 270 CONTINUE SNOW=LOWEST 300 CONTINUE DO 320 I=1,5 DO 310 J=1,NPS PS(I,J)=PS2(I,J) 310 CONTINUE 320 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7775) 7775 FORMAT(/ /' CONTOUR POINTS ON SIDES, AFTER SORTING:'/) DO 102 INPS=1,NPS XQ=PHIVAL(PS(1,INPS),PS(2,INPS),PS(3,INPS),X1,X2,X3,X4,X5,X6) YQ=PHIVAL(PS(1,INPS),PS(2,INPS),PS(3,INPS),Y1,Y2,Y3,Y4,Y5,Y6) WRITE(6,7774)INPS,(PS(J,INPS),J=1,4),XQ,YQ 102 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C CREATE TABLE OF ELEMENT-SIDE SEGMENTS C S=0. NPSD=0 BEGNXT=.FALSE. C BEGIN NEW SEGMENT 400 ISPNUM=ISPNUM+1 IF (ISPNUM.GT.NINLIN) THEN NCRASH=4 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF ISPPNT(ISPNUM)=ISPPNT(ISPNUM-1)+ISPLEN(ISPNUM-1) IF (ISPPNT(ISPNUM).GT.NWORK) THEN NCRASH=5 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF 401 FORMAT(' INSUFFICIENT WORKSPACE IN SUBPROGRAM CONTEL. ELEMENT ', & I5,' WILL NOT BE SHOWN. DEBUGGING CODE NCRASH=',I3) ISPLEN(ISPNUM)=1 NTOGO(ISPNUM)=1 ANEDGE(ISPNUM)=.TRUE. BEGCON=BEGNXT NINSEG=1 IF(S.LE.1.) THEN S1=1.-S S2=S S3=0. ELSE IF (S.LE.2.) THEN S1=0. S2=2.-S S3=S-1. ELSE S1=S-2. S2=0. S3=3.-S ENDIF X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) F=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) SUMSEG=F SPACE(1,ISPPNT(ISPNUM))=X SPACE(2,ISPPNT(ISPNUM))=Y C FIND NEXT POINT 500 IS=IABOVE(S/DSTEP+0.05) IF (S.LT.1.0) THEN SLIM=1.0 ELSE IF (S.LT.2.0) THEN SLIM=2.0 ELSE SLIM=3.0 ENDIF ST=MIN(SLIM,IS*DSTEP) THRU=.FALSE. ENDCON=.FALSE. BEGNXT=.FALSE. IF (NPSD.LT.NPS) THEN IF (PS(5,NPSD+1).LE.ST) THEN NPSD=NPSD+1 IF ((.NOT.ALLPOS).OR.(PS(4,NPSD).GT.0.0)) THEN THRU=.TRUE. ENDCON=.TRUE. BEGNXT=.TRUE. ST=PS(5,NPSD) ENDIF ENDIF ENDIF IF (ST.EQ.SLIM) THRU=.TRUE. C UPDATE REPRESENTATIVE FUNCTION VALUE FOR SEGMENT NINSEG=NINSEG+1 IF(ST.LE.1.) THEN S1=1.-ST S2=ST S3=0. ELSE IF (ST.LE.2.) THEN S1=0. S2=2.-ST S3=ST-1. ELSE S1=ST-2. S2=0. S3=3.-ST ENDIF F=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) BITSEG=THRU.AND.(NINSEG.EQ.2).AND.BEGCON.AND.ENDCON.AND. + (ABS(F-SUMSEG).LT.(0.1*ABS(DFCON))) IF (BITSEG) THEN IF (F.GT.FOFSEG(ISPNUM-1)) THEN FOFSEG(ISPNUM)=F+0.5*ABS(DFCON) ELSE FOFSEG(ISPNUM)=F-0.5*ABS(DFCON) ENDIF ELSE SUMSEG=SUMSEG+F FOFSEG(ISPNUM)=SUMSEG/NINSEG ENDIF C RECORD NEXT POINT IN LIST X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) ISPLEN(ISPNUM)=ISPLEN(ISPNUM)+1 IF ((ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1).GT.NWORK) THEN NCRASH=6 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF SPACE(1,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=X SPACE(2,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=Y S=ST IF (S.LT.3.0) THEN IF (THRU) THEN GO TO 400 ELSE GO TO 500 ENDIF ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7779) 7779 FORMAT(/ / /' TABLE OF NON-CONTOUR SEGMENTS ALONG SIDES:'/ + ' NUMBER FOFSEG ISPPNT ISPLEN ', + 'X, Y OF FIRST POINT X,Y OF LAST POINT') DO 107 I=1,ISPNUM WRITE(6,7780)I,FOFSEG(I),ISPPNT(I),ISPLEN(I), + (SPACE(J,ISPPNT(I)),J=1,2), + (SPACE(J,ISPPNT(I)+ISPLEN(I)-1),J=1,2) 7780 FORMAT(' ',I5,5X,1P,E10.3,0P,2I10,1P,4E10.3) 107 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C CLEAN-UP THE SEGMENT F VALUES TO MID-RANGE NUMBERS C DO 550 I=1,ISPNUM T=FOFSEG(I)/DFCON IF (ALLPOS) T=MAX(T,0.0) T=IUNDER(T)+0.5 FOFSEG(I)=T*DFCON 550 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7782) DFCON 7782 FORMAT(/ / ' REVISED FOFSEG VALUES: (DFCON=', + 1P,E12.5,')') DO 108 I=1,ISPNUM WRITE(6,7784)I,FOFSEG(I) 7784 FORMAT(' ',I10,1P,E10.3) 108 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C*************************************************************** C C SEARCH FOR EXTREMUM WITHIN DOMAIN OF ELEMENT C CDET=16.*(-F6**2+2.*F6*F5+2.*F6*F4-2.*F6*F2-F5**2+2.*F5*F4 + -2.*F5*F1-F4**2-2.*F4*F3+F3*F2+F3*F1+F2*F1) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7785) CDET 7785 FORMAT(/' EXTREMUM DETERMINANT CDET=',1P,E12.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (ABS(CDET).LT. 1.E-40) GO TO 1000 S2EXT=(4.*F6**2-4.*F6*F5-4.*F6*F4-F6*F3+2.*F6*F2-F6*F1+F5* + F3+3.*F5*F1+3.*F4*F3+F4*F1-F3*F2-2.*F3*F1-F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S3EXT=(-4.*F6*F4+3.*F6*F2+F6*F1-4.*F5*F4+F5*F2+3.*F5*F1+4. + *F4**2+2.*F4*F3-F4*F2-F4*F1-F3*F2-F3*F1-2.*F2*F1)/(4.*(F6 + **2-2.*F6*F5-2.*F6*F4+2.*F6*F2+F5**2-2.*F5*F4+2.*F5*F1+F4 + **2+2.*F4*F3-F3*F2-F3*F1-F2*F1)) S1EXT=1.0-S2EXT-S3EXT C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7786)S1EXT,S2EXT,S3EXT 7786 FORMAT(/' EXTREMUM AT S1-3=',3F10.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (S1EXT.GT.0.99999.OR.S1EXT.LT.0.00001) GO TO 1000 IF (S2EXT.GT.0.99999.OR.S2EXT.LT.0.00001) GO TO 1000 IF (S3EXT.GT.0.99999.OR.S3EXT.LT.0.00001) GO TO 1000 C C REJECT SADDLE POINTS C DISCA=F1-2.*F4+F2 DISCB=F2-2.*F5+F3 DISCC=F3-2.*F6+F1 CENTER=((DISCA.GT.0.).AND.(DISCB.GT.0.).AND.(DISCC.GT.0.)) + .OR.((DISCA.LT.0.).AND.(DISCB.LT.0.).AND.(DISCC.LT.0.)) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,7789) CENTER,DISCA,DISB,DISC 7789 FORMAT(/' CENTER=',L2,' BECAUSE DISCA-C=',1P,3E12.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (.NOT.CENTER) GO TO 1000 XEXT=PHIVAL(S1EXT,S2EXT,S3EXT,X1,X2,X3,X4,X5,X6) YEXT=PHIVAL(S1EXT,S2EXT,S3EXT,Y1,Y2,Y3,Y4,Y5,Y6) FEXT=PHIVAL(S1EXT,S2EXT,S3EXT,F1,F2,F3,F4,F5,F6) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8801)XEXT,YEXT,FEXT 8801 FORMAT(/' EXTREMUM IS AT X=',1P,E10.3,', Y=',E10.2, + ', F=',E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ FMAX=MAX(FMAX,FEXT) FMIN=MIN(FMIN,FEXT) C C FIND CONTOUR STARTING/STOPPING POINT ALONG CHORD FROM A NODE TO EXT. C NCL=1 DIFF=ABS(F1-FEXT) DS(1)=S1EXT-1. DS(2)=S2EXT DS(3)=S3EXT DO 600 J=2,6 DFF=ABS(FN(J)-FEXT) IF (DFF.LT.DIFF) THEN NCL=J DIFF=DFF DS(1)=S1EXT DS(2)=S2EXT DS(3)=S3EXT IF (J.EQ.2) DS(2)=S2EXT-1. IF (J.EQ.3) DS(3)=S3EXT-1. IF (J.EQ.4.OR.J.EQ.6) DS(1)=S1EXT-0.5 IF (J.EQ.4.OR.J.EQ.5) DS(2)=S2EXT-0.5 IF (J.EQ.5.OR.J.EQ.6) DS(3)=S3EXT-0.5 ENDIF 600 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8812)NCL,DIFF,(DS(K),K=1,3) 8812 FORMAT(/' PARTITION LINE:'/ + ' NCL=',I10,' DIFF=',1P,E10.3,' DS(1-3)=',0P, + 3F10.5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ CALL DOLINE (FEXT,DFCON,FN,NCL,DS,S1EXT,S2EXT,S3EXT, + IHIC,ILOC,PS,NPS,NINLIN,Z) IF (Z) THEN NCRASH=7 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF C C END OF CODE RELATED TO CASE OF AN INTERNAL EXTREMUM C C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT.AND.(NPS.GT.0)) THEN WRITE(6,8821) 8821 FORMAT(/ /' TABLE OF CONTOUR STARTING POINTS:') DO 8825 I=1,NPS XQ=PHIVAL(PS(1,I),PS(2,I),PS(3,I),X1,X2,X3,X4,X5,X6) YQ=PHIVAL(PS(1,I),PS(2,I),PS(3,I),Y1,Y2,Y3,Y4,Y5,Y6) WRITE(6,8823)I,(PS(K,I),K=1,4),XQ,YQ 8823 FORMAT(' ',I10,0P,3F10.5,1P,3E10.3) 8825 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ 1000 IF (NPS.EQ.0) GO TO 9001 C C************************************************************* C C INTEGRATE ALL CONTOUR SEGMENTS C DO 1150 K=1,NPS DONE(K)=.FALSE. 1150 CONTINUE DO 9000 N=1,NPS C C INTEGRATE ONE CONTOUR SEGMENT C IF (.NOT.DONE(N)) THEN C C INITIALIZE INTEGRATION OF CONTOUR C DONE(N)=.TRUE. FVALUE=PS(4,N) IF (ALLPOS.AND.(FVALUE.LE.0.0)) GO TO 9000 ISPNUM=ISPNUM+1 C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8831)ISPNUM,FVALUE 8831 FORMAT(/' HISTORY OF SEGMENT ',I5,' (',1P,E10.3,')') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (ISPNUM.GT.NINLIN) THEN NCRASH=8 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF FOFSEG(ISPNUM)=FVALUE ISPPNT(ISPNUM)=ISPPNT(ISPNUM-1)+ISPLEN(ISPNUM-1) IF (ISPPNT(ISPNUM).GT.NWORK) THEN NCRASH=9 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF ISPLEN(ISPNUM)=1 NTOGO(ISPNUM)=2 ANEDGE(ISPNUM)=.FALSE. S1=PS(1,N) S2=PS(2,N) S3=PS(3,N) INSIDE=(S1*S2*S3).GT.0.0 S1OLD=S1 S2OLD=S2 S3OLD=S3 X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) SPACE(1,ISPPNT(ISPNUM))=X SPACE(2,ISPPNT(ISPNUM))=Y ANGLE=0. IF (CENTER) ANGLE=ATAN2((Y-YEXT),(X-XEXT)) ANGLEP=ANGLE ROT=0. DFDS2=-4.*S3*F6+4.*S3*F5-4.*S3*F4+4.*S3*F1-8.*S2*F4+4.*S2* + F2+4.*S2*F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3*F6+4.*S3*F3+4.*S3*F1-4.*S2*F6+4.*S2*F5-4.*S2* + F4+4.*S2*F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX DS2=ROUNDX*DSTEP*0.1 DS3=ROUNDY*DSTEP*0.1 C C REVERSE INTEGRATION STEP DIRECTION IF CONTOUR POINTS OUTWARD C S2P=S2+DS2 S3P=S3+DS3 S1P=1.00-S2P-S3P COUNTR=1. IF ( (S1P.LT.0..OR.S1P.GT.1.) + .OR.(S2P.LT.0..OR.S2P.GT.1.) + .OR.(S3P.LT.0..OR.S3P.GT.1.)) COUNTR= -1. NSEG=0 C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,3412)ISPPNT(ISPNUM),X,Y,ANGLE 3412 FORMAT(' BEGINNING AT ISPPNT=',I10,' X=',1P,E10.3, + ' Y=',E10.3,' ANGLE=',0P,F10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C C BEGIN LOOP OF INTEGRATION OF CONTOUR LINE C-------------------------------------------- C 3000 NSEG=NSEG+1 C EXTRAPOLATE TO NEXT POINT BY FORWARD METHOD DS2=ROUNDX*COUNTR*DSTEP DS3=ROUNDY*COUNTR*DSTEP S2P=S2+DS2 S3P=S3+DS3 S1P=1.00-S2P-S3P C RECOMPUTE SAME STEP BY BACKWARD METHOD DFDS2=-4.*S3P*F6+4.*S3P*F5-4.*S3P*F4 + +4.*S3P*F1-8.*S2P*F4+4.*S2P* + F2+4.*S2P*F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3P*F6+4.*S3P*F3+4.*S3P*F1 + -4.*S2P*F6+4.*S2P*F5-4.*S2P* + F4+4.*S2P*F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX DS2P=ROUNDX*DSTEP*COUNTR DS3P=ROUNDY*DSTEP*COUNTR C ACTUAL INTEGRATION STEP BY TRAPEZOIDAL METHOD DS2=0.5*(DS2+DS2P) DS3=0.5*(DS3+DS3P) DSLEN=SQRT(DS2**2+DS3**2) IF((DSLEN/DSTEP).LT.0.10) GO TO 8999 S2=S2+DS2 S3=S3+DS3 S1=1.00-S2-S3 C CORRECT CONTOUR TO ACTUAL VALUE DESIRED TRIAL=PHIVAL(S1,S2,S3,F1,F2,F3,F4,F5,F6) ERRER=TRIAL-FVALUE IF (ABS(ERRER).GE.DFCON) GO TO 8999 DFDS2=-4.*S3 *F6+4.*S3 *F5-4.*S3 *F4 + +4.*S3 *F1-8.*S2 *F4+4.*S2 * + F2+4.*S2 *F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3 *F6+4.*S3 *F3+4.*S3 *F1 + -4.*S2 *F6+4.*S2 *F5-4.*S2 * + F4+4.*S2 *F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF DISTNC= -ERRER/(GRADF*GSIZE) IF (ABS(DISTNC).GT.DSTEP) DISTNC= + DISTNC*DSTEP/ABS(DISTNC) S2=S2+DISTNC*GRADFX S3=S3+DISTNC*GRADFY S1=1.00-S2-S3 C DECIDE WHETHER CONTOUR IS FINISHED OR NOT HITLIM=NSEG.GE.LIMINT IF (HITLIM) WRITE(6,3501)FVALUE,I 3501 FORMAT(' ',1PE10.2,' CONTOUR IN ELEMENT ',I3, + ' SEEMS TO BE IN LOOP. TERMINATED.') GONOUT=(S1.LT.0..OR.S1.GT.1.).OR. + (S2.LT.0..OR.S2.GT.1.).OR. + (S3.LT.0..OR.S3.GT.1.) FINISH=GONOUT.OR.HITLIM IF (CENTER) THEN XT=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YT=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) ANGLEP=ATAN2((YT-YEXT),(XT-XEXT)) DROT=MIN(ABS(ANGLEP-ANGLE), & 6.2832-ABS(ANGLEP-ANGLE)) ROT=ROT+DROT CIRCLE=ROT.GE.6.2832 FINISH=FINISH.OR.CIRCLE IF (CIRCLE.AND.INSIDE) THEN S1=PS(1,N) S2=PS(2,N) S3=PS(3,N) ENDIF ENDIF C IF VECTOR EXTENDS OUTSIDE OF THE ELEMENT, SHORTEN IT ....... IF (GONOUT) THEN RAT=1.0 IF(S1.GT.1.)RAT=AMIN1(RAT,((1.-S1OLD)/(S1-S1OLD))) IF(S2.GT.1.)RAT=AMIN1(RAT,((1.-S2OLD)/(S2-S2OLD))) IF(S3.GT.1.)RAT=AMIN1(RAT,((1.-S3OLD)/(S3-S3OLD))) IF(S1.LT.0.)RAT=AMIN1(RAT,((0.-S1OLD)/(S1-S1OLD))) IF(S2.LT.0.)RAT=AMIN1(RAT,((0.-S2OLD)/(S2-S2OLD))) IF(S3.LT.0.)RAT=AMIN1(RAT,((0.-S3OLD)/(S3-S3OLD))) RAT=AMAX1(RAT,0.0) S2=S2OLD+(S2-S2OLD)*RAT S3=S3OLD+(S3-S3OLD)*RAT S1=1.00-S2-S3 C .... AND CROSS OFF THE CORRESPONDING SIDE-CROSSING POINT IF ((N.LT.NPS).AND.(.NOT.INSIDE)) THEN XE=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) YE=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) MATE=N R2MIN=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) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,3210)MATE 3210 FORMAT(' (CROSSING OFF STARTING POINT ',I5,')') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ ENDIF ENDIF C LOCATE (X,Y) COORDINATES OF DESTINATION POINT X=PHIVAL(S1,S2,S3,X1,X2,X3,X4,X5,X6) Y=PHIVAL(S1,S2,S3,Y1,Y2,Y3,Y4,Y5,Y6) C STORE (X,Y) COORDINATES FOR LATER ISPLEN(ISPNUM)=ISPLEN(ISPNUM)+1 IF ((ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1).GT.NWORK) THEN NCRASH=10 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF SPACE(1,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=X SPACE(2,ISPPNT(ISPNUM)+ISPLEN(ISPNUM)-1)=Y C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,4026)S1,S2,S3,X,Y 4026 FORMAT(' S1-3=',0P,3F10.5,' X=',1P,E10.3,' Y=',E10.3) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$4 C PREPARE FOR NEXT ITERATION IF ONE IS NEEDED S1OLD=S1 S2OLD=S2 S3OLD=S3 IF (.NOT.FINISH) THEN DFDS2=-4.*S3 *F6+4.*S3 *F5-4.*S3 *F4 + +4.*S3 *F1-8.*S2 *F4+4.*S2 * + F2+4.*S2 *F1+4.*F4-F2-3.*F1 DFDS3=-8.*S3 *F6+4.*S3 *F3+4.*S3 *F1 + -4.*S2 *F6+4.*S2 *F5-4.*S2 * + F4+4.*S2 *F1+4.*F6-F3-3.*F1 GSIZE=MAX(ABS(DFDS2),ABS(DFDS3)) IF (GSIZE.EQ.0.0) GO TO 8999 DFDS2=DFDS2/GSIZE DFDS3=DFDS3/GSIZE GRADF=SQRT(DFDS2**2+DFDS3**2) GRADFX=DFDS2/GRADF GRADFY=DFDS3/GRADF ROUNDX= +GRADFY ROUNDY= -GRADFX ANGLE=ANGLEP C C END LOOP OF PUSHING FORWARD ONE CONTOUR SEGMENT C ------------------------------------------ C GO TO 3000 ENDIF C PROVIDE EMERGENCY TERMINATION POINT FOR BEWILDERED CONTOURS 8999 CONTINUE C END OF CODE EXECUTED IF (SEGMENT NOT ALREADY INTEGRATED) ENDIF C CLOSE LOOP ON ALL CONTOUR SEGMENTS 9000 CONTINUE C C**************************************************************** C C BEGIN C CONNECTION OF CONTOUR SEGMENTS AND EDGE SEGMENTS TO CLOSE AREAS C 9001 LEVEL1=IUNDER(FMIN/DFCON) LEVEL2=IUNDER(FMAX/DFCON) IF (ALLPOS) LEVEL1=MAX(LEVEL1,0) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,9542)LEVEL1,LEVEL2 9542 FORMAT(/ / /' BASE (UNDER) LEVELS ARE LEVEL1=',I5, + ' LEVEL2=',I5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ DO 9900 IC=LEVEL1,LEVEL2 FCENTR=(IC+0.5)*DFCON IF (ALLPOS) THEN FCENTC=MAX(FCENTR,0.5*DFCON) ELSE FCENTC=FCENTR ENDIF N=IHUE(NCOLOR,DFCON,FMIDLE,IFLIP,FCENTC) IF (COLOR) THEN CALL TONCLR(ICOLOR(N)) IF (N.EQ.1) THEN KOLORC=9 SURROU=.TRUE. C OUTLINE OFF-SPECTRUM LOW (BLACK?) AREAS W/ WHITE ELSE IF (N.EQ.NCOLOR) THEN KOLORC=1 SURROU=.TRUE. C OUTLINE OFF-SPECTRUM HIGH (WHITE?) AREAS W/ BLACK ELSE SURROU=.FALSE. C DO NOT SURROUND COLORED AREAS WITH CONTOURS IF (N.GE.2.AND.N.LE.4) NBLUE=NBLUE+1 IF (N.GE.6.AND.N.LE.8) NYELOW=NYELOW+1 ENDIF IF (ALLPOS.AND.FCENTR.LT.0.0) THEN SURROU=.FALSE. ENDIF ELSE CALL SETPAT(N) SURROU=.TRUE. KOLORC=1 C MEANS SURROUND ALL AREAS WITH BLACK CONTOURS ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,4056)IC ,N 4056 FORMAT(/' FOR BASE LEVEL ',I5,' HUE OR PATTERN=',I5) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ C BUILD MENU OF RELEVANT SEGMENTS (SO THAT NONE IS USED TWICE) NMENU=0 DO 9020 I=1,ISPNUM IF(ABS((FOFSEG(I)-FCENTR)/DFCON).LE.0.75) THEN IF (NTOGO(I).GT.0) THEN NTOGO(I)=NTOGO(I)-1 NMENU=MIN(NMENU+1,NINLIN) MENU(NMENU)=I ENDIF ENDIF 9020 CONTINUE C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,4278) 4278 FORMAT(/' MENU OF SEGMENTS:'/ + ' INDEX SEGMENT') DO 4280 I=1,NMENU WRITE(6,4279)I,MENU(I) 4279 FORMAT(' ',2I10) 4280 CONTINUE ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ NAREAS=0 NPOLY=0 C DRAW ONE OR MORE CLOSED AREAS FROM MENU OF RELEVANT SEGMENTS C (NEXT STATEMENT IS BEGINNING OF INDEFINITE LOOP ON AREAS) 9050 IF (NMENU.LE.0) GO TO 9900 IF (NAREAS.LT.MXAREA) THEN NAREAS=NAREAS+1 ELSE NCRASH=11 WRITE(6,401) IEL,CRASH GO TO 9999 ENDIF NINARE(NAREAS)=0 C BEGIN EACH CLOSED AREA WITH THE TOP SEGMENT IN THE MENU C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,8238) 8238 FORMAT(/' BEGINNING NEW CLOSED AREA; SEGMENTS USED ARE:') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IDISH=1 NADD=+1 I1=ISPPNT(MENU(1)) XORIGN=SPACE(1,I1) YORIGN=SPACE(2,I1) C BEGIN INDEFINATE LOOP ON SEGMENTS IN ONE AREA C ------------------------------------- 9100 NAME=MENU(IDISH) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,3756)NAME,NADD 3756 FORMAT(' ',I5,I10) ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (ANEDGE(NAME)) THEN KOLORP=0 ELSE KOLORP=KOLORC ENDIF IF (NADD.EQ.1) THEN I1=ISPPNT(NAME) I2=I1+ISPLEN(NAME)-1 ELSE I2=ISPPNT(NAME) I1=I2+ISPLEN(NAME)-1 ENDIF DO 9500 I=I1,I2,NADD X=SPACE(1,I) Y=SPACE(2,I) IF (NPOLY.LT.NPOLYV) THEN NPOLY=NPOLY+1 NINARE(NAREAS)=NINARE(NAREAS)+1 ELSE NCRASH=12 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF XARRAY(NPOLY)=X YARRAY(NPOLY)=Y IPCLR(NPOLY)=KOLORP 9500 CONTINUE C DROP SEGMENT FROM MENU IMMEDIATELY AFTER DRAWING NMENU=NMENU-1 DO 9510 J=IDISH,NMENU MENU(J)=MENU(J+1) 9510 CONTINUE C IF NECESSARY, STRING TOGETHER OTHER SEGMENTS TO COMPLETE AREA IF (NMENU.LE.0) GO TO 9895 RMIN=1.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 C DECISION POINT: POSSIBLE END OF INNER LOOP ON SEGMENTS R=SQRT((X-XORIGN)**2+(Y-YORIGN)**2) IF (R.GT.RMIN) THEN C LOOP IS NOT FINISHED; GET MORE SEGMENTS. GO TO 9100 ELSE C LOOP IS FINISHED; TIDY UP AND BEGIN ANOTHER. IF (R.GT.0.) THEN IF (NPOLY.LT.NPOLYV) THEN NPOLY=NPOLY+1 NINARE(NAREAS)=NINARE(NAREAS)+1 ELSE NCRASH=13 WRITE(6,401) IEL,NCRASH GO TO 9999 ENDIF XARRAY(NPOLY)=XORIGN YARRAY(NPOLY)=YORIGN IPCLR(NPOLY)=KOLORP ENDIF IF (NMENU.GT.0) GO TO 9050 ENDIF C C CALL FOR SHADING OF THE AREA(S) OF A SINGLE COLOR C 9895 CALL TONE(XARRAY,YARRAY,NINARE,NAREAS) C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (DUMPIT) THEN WRITE(6,3945) 3945 FORMAT(' PAINTING AND OUTLINING THIS AREA...') ENDIF C$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ IF (SURROU) THEN C IF AREAS ARE TO BE OUTLINED, THEN C DRAW OUTLINES OF AREA(S) WITH PEN C N2=0 DO 9899 KAREA=1,NAREAS N1=N2+1 N2=N1+NINARE(KAREA)-1 CALL PLOT(XARRAY(N1),YARRAY(N1),3) DO 9898 J=N1+1,N2 KOLORP=IPCLR(J) IF (KOLORP.EQ.0) THEN IPEN=3 C LIFT PEN ELSE IPEN=2 C LOWER PEN, POSSIBLY COLORED IF (COLOR.AND.(KOLORP.NE.LASTKO)) THEN CALL PENCLR(IPENCT,KOLORP) CALL NEWPEN(IPENCT) LASTKO=KOLORP ENDIF ENDIF CALL PLOT(XARRAY(J),YARRAY(J),IPEN) 9898 CONTINUE 9899 CONTINUE ENDIF C C CLOSE LOOP ON THE DIFFERENT COLOR LEVELS IN ONE ELEMENT C 9900 CONTINUE C C *************************************************************** C C CLOSE LOOP ON ALL ELEMENTS FGMAX=MAX(FGMAX,FMAX) FGMIN=MIN(FGMIN,FMIN) 9999 CONTINUE IF (COLOR) THEN CALL PENCLR(IPENCT,1) CALL NEWPEN(IPENCT) ENDIF RETURN END C C C SUBROUTINE DOSIDE (FMAX,FMIN,DFCON,FN,N1,N2,NM,PS,NPS,NINLIN,Z) C C FIND BEGINNING/END POINTS OF CONTOURS ALONG SIDE OF ELEMENT C LOGICAL Z DIMENSION FN(6),PS(5,NINLIN) ILOW=IUNDER(FMIN/DFCON) IF (FMIN.EQ.(DFCON*ILOW)) ILOW=ILOW-1 IHI=IABOVE(FMAX/DFCON) IF (FMAX.EQ.(DFCON*IHI)) IHI=IHI+1 NBTWEN=IHI-ILOW-1 IF (NBTWEN.GE.1) THEN NBASE=ILOW A=2.*FN(N1)-4.*FN(NM)+2.*FN(N2) B= -3.*FN(N1)+4.*FN(NM)-FN(N2) DO 10 K=1,NBTWEN N=K+NBASE F=N*DFCON C= FN(N1)-F IF (A.NE.0.) THEN DISC=SQRT(MAX(B**2-4.*A*C,0.)) ROOT1=(-B+DISC)/(2.*A) ROOT2=(-B-DISC)/(2.*A) OUT1=MAX(MAX(0.,-ROOT1),MAX(0.,ROOT1-1.)) OUT2=MAX(MAX(0.,-ROOT2),MAX(0.,ROOT2-1.)) IF (OUT1.LE.OUT2) THEN IF (OUT1.GT.0.10)GO TO 10 S=ROOT1 ELSE IF (OUT2.GT.0.10)GO TO 10 S=ROOT2 ENDIF ELSE IF (FN(N2).NE.FN(N1)) THEN S=(F-FN(N1))/(FN(N2)-FN(N1)) ELSE S=0. ENDIF Z=(NPS.GE.NINLIN) IF (Z) RETURN NPS=NPS+1 PS(N1,NPS)=1.-S PS(N2,NPS)=S N3=6-N1-N2 PS(N3,NPS)=0. PS(4,NPS)=F 10 CONTINUE ENDIF RETURN END C C C SUBROUTINE DOPART (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 PLOT(X,Y,3) DO 20 K=1,ISTEP DO 15 L=1,3 S(L)=S(L)+DS(L) 15 CONTINUE X=PHIVAL(S(1),S(2),S(3),X1,X2,X3,X4,X5,X6) Y=PHIVAL(S(1),S(2),S(3),Y1,Y2,Y3,Y4,Y5,Y6) CALL PLOT(X,Y,2) 20 CONTINUE 100 CONTINUE RETURN END 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 PLOT(XP,YP,2) ELSE CALL PLOT(XP,YP,3) ENDIF 100 CONTINUE RETURN END C C C SUBROUTINE ARROW (NUMEL,OUTVEC,RMSVEC, + XIP,YIP,CINT,XMAX,YTOP) C C DRAWS VECTORS WITH RMS LENGTH RMSVEC INCHES FROM ELEMENT C CENTERS. C THEN DRAWS A LARGE SAMPLE ARROW IN A BOX UP AGAINST LIMITS C XMAX AND YTOP. C DIMENSION OUTVEC(2,7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) CHARACTER*8 SCALE SUM=0. BIG=0. DO 100 I=1,NUMEL T=OUTVEC(1,1,I)**2+OUTVEC(2,1,I)**2 SUM=SUM+T BIG=MAX(BIG,T) 100 CONTINUE IF (SUM.LE.0.) RETURN FACTR=RMSVEC/SQRT(SUM/NUMEL) BIG=SQRT(BIG) BIG=MIN(BIG,2.*RMSVEC/FACTR) N=BIG/CINT+0.5 BIG=MAX(N,1)*CINT DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) CALL PLOT(X,Y,3) DX=FACTR*OUTVEC(1,1,I) DY=FACTR*OUTVEC(2,1,I) XP=X+DX YP=Y+DY CALL PLOT(XP,YP,2) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XP+BX,YP+BY,2) 200 CONTINUE CALL PLOT(XMAX,YTOP,3) WIDE=MAX(0.85,(0.1+BIG*FACTR+0.1)) HIGH=0.4 CALL PLOT(XMAX-WIDE,YTOP,2) CALL PLOT(XMAX-WIDE,YTOP-HIGH,2) CALL PLOT(XMAX,YTOP-HIGH,2) CALL PLOT(XMAX,YTOP,2) X=XMAX-0.5*WIDE-0.5*BIG*FACTR Y=YTOP-0.15 CALL PLOT(X,Y,3) DX=BIG*FACTR DY=0. XP=X+DX YP=Y+DY CALL PLOT(XP,YP,2) AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XP+BX,YP+BY,2) WRITE(SCALE,390)BIG 390 FORMAT(1P,E8.1) DO 400 I=1,8 IF (SCALE(I:I).EQ.'0') THEN SCALE(I:I)='O' ENDIF 400 CONTINUE CALL SYMBOL(XMAX-0.85-0.5*(WIDE-0.85),YTOP-HIGH+0.03, + 0.12,SCALE,IDUMMY,0.,8) RETURN END C C C SUBROUTINE AXES (NUMEL,TAUMT,TAUZZ,RMSVEC,IPEN, + XIP,YIP,CINT,XMAX,YTOP) C C DRAWS TENSOR PRINCIPAL AXES, WITH RMS LENGTH RMSVEC INCHES, C AT ELEMENT CENTERS. C CONVENTION IS THAT AN AXIS IS COMPRESSIVE (INWARD-POINTING) C IF THE CORRESPONDING PRINCIPAL VALUE OF THE TENSOR IS NEGATIVE. C ALSO DRAWS 2 LARGE SAMPLE TENSORS (ISOTROPIC, + AND - SAMPLES) C IN A BOX UP AGAINST LIMITS XMAX AND YTOP (INCHES). C CHARACTER*8 SCALE DIMENSION TAUMT(3,7,NUMEL),TAUZZ(7,NUMEL), + XIP(7,NUMEL),YIP(7,NUMEL) C 1001 FORMAT(1P,E8.1) C SUM=0. BIG=0. DO 100 I=1,NUMEL TZZ=TAUZZ(1,I) TXX=TAUMT(1,1,I)+TZZ TYY=TAUMT(2,1,I)+TZZ TXY=TAUMT(3,1,I) SHEAR=SQRT(TXY**2+0.25*(TXX-TYY)**2) CENTER=(TXX+TYY)/2. T1=CENTER-SHEAR T2=CENTER+SHEAR SUM=SUM+(MAX(ABS(T1),ABS(T2),ABS(TZZ)))**2 BIG=MAX(BIG,ABS(T1),ABS(T2)) 100 CONTINUE IF (SUM.LE.0.) RETURN FACTR=0.5*RMSVEC/SQRT(SUM/NUMEL) BIG=MIN(BIG,2.*RMSVEC/FACTR) N=BIG/CINT+0.5 BIG=MAX(N,1)*CINT C DO 200 I=1,NUMEL X=XIP(1,I) Y=YIP(1,I) 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 CIRCLE(X,Y,-DR,MIN0(IPEN,7)) ELSE IF (TZZ.GT.0.0) THEN C TRIANGLE FOR TENSILE VERTICAL STRESS ANOMALY CALL PLOT(X+0.866*DR,Y-0.5*DR,3) CALL PLOT(X,Y+DR,2) CALL PLOT(X-0.866*DR,Y-0.5*DR,2) CALL PLOT(X+0.866*DR,Y-0.5*DR,2) 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 PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) ELSE C COMPRESSIVE PRINCIPAL STRESS ANOMALY CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) ENDIF DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) IF (T2.GT.0.0) THEN C TENSILE PRINCIPAL STRESS ANOMALY CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) ELSE C COMPRESSIVE PRINCIPAL STRESS ANOMALY CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) ENDIF 200 CONTINUE C C PLOT REFERENCE BOX C CALL PLOT(XMAX,YTOP,3) WIDE=MAX(0.85,(0.1+2.*BIG*FACTR+0.1+2.*BIG*FACTR+0.1)) HIGH=0.2+2.*BIG*FACTR+0.1 CALL PLOT(XMAX-WIDE,YTOP,2) CALL PLOT(XMAX-WIDE,YTOP-HIGH,2) CALL PLOT(XMAX,YTOP-HIGH,2) CALL PLOT(XMAX,YTOP,2) ANGLE=0. DR=BIG*FACTR C C ISOTROPIC COMPRESSIVE TENSOR C X=XMAX-WIDE+0.1+DR Y=YTOP-0.1-DR TZZ= -BIG T1= -BIG T2= -BIG CALL CIRCLE(X,Y,-DR,MIN0(IPEN,7)) DX=FACTR*T1*COS(ANGLE) DY=FACTR*T1*SIN(ANGLE) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(X+AX,Y+AY,3) CALL PLOT(X-AX,Y-AY,2) CALL PLOT(X+BX,Y+BY,3) CALL PLOT(X-BX,Y-BY,2) C C ISOTROPIC EXTENSIONAL TENSOR C X=XMAX-0.1-DR Y=YTOP-0.1-DR TZZ=BIG T1=BIG T2=BIG CALL PLOT(X+0.866*DR,Y-0.5*DR,3) CALL PLOT(X,Y+DR,2) CALL PLOT(X-0.866*DR,Y-0.5*DR,2) CALL PLOT(X+0.866*DR,Y-0.5*DR,2) DX=FACTR*T1*COS(ANGLE) DY=FACTR*T1*SIN(ANGLE) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) DX=FACTR*T2*COS(ANGLE+1.5708) DY=FACTR*T2*SIN(ANGLE+1.5708) XP=X+DX YP=Y+DY XN=X-DX YN=Y-DY AX=DX*(-.217)+DY*(-.125) AY=DX*(+.125)+DY*(-.217) BX=DX*(-.217)+DY*(+.125) BY=DX*(-.125)+DY*(-.217) CALL PLOT(XN,YN,3) CALL PLOT(XP,YP,2) CALL PLOT(XP+AX,YP+AY,2) CALL PLOT(XP,YP,3) CALL PLOT(XP+BX,YP+BY,2) CALL PLOT(XN-AX,YN-AY,3) CALL PLOT(XN,YN,2) CALL PLOT(XN-BX,YN-BY,2) C C WRITE LABEL C WRITE(SCALE,390)BIG 390 FORMAT(1P,E8.1) DO 400 I=1,8 IF (SCALE(I:I).EQ.'0') THEN SCALE(I:I)='O' ENDIF 400 CONTINUE CALL SYMBOL(XMAX-0.85-0.5*(WIDE-0.85),YTOP-HIGH+0.03, + 0.12,SCALE,IDUMMY,0.,8) 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=* //LKED EXEC PGM=IEWL,REGION=3500K,COND=(4,LT,FORT),PARM='MAP,LIST' //SYSLIB DD DISP=(SHR,PASS),DSN=APP1.FORTVS.LIBRARY (FORTRAN) // DD DISP=(SHR,PASS),DSN=APP1.ESSLV (LINEAR EQUATIONS) // DD DISP=(SHR,PASS),DSN=APP1.VTEC21.FORT77 (PLOTTING) //SYSLIN DD DSN=&&LOADSET,DISP=(OLD,DELETE) // DD DDNAME=SYSIN //SYSLMOD DD DISP=(NEW,CATLG),UNIT=DATA, CREATE LOAD // SPACE=(TRK,(35,20,1)),DSN=EIQ2GPB.VERSMOD(GO) MODULE. //SYSIN DD * ENTRY MAIN /* //SYSPRINT DD SYSOUT=* //SYSUT1 DD UNIT=VIO,SPACE=(TRK,(5,5),,,ROUND) //