C
C C ************************ C C THE PROGRAM RAYPLOT IS DESIGNED FOR PLOTTING OF RAY DIAGRAMS, C TRAVEL TIMES AND AMPLITUDES OF SEISMIC BODY WAVES FROM THE C FILE LU GENERATED BY PROGRAM SEIS88 C C **************************************************************** C character*80 text DIMENSION A(30),B(30),C(30),D(30),X1(30),III(30),NPNT(20) DIMENSION X(400),T(400),XZ(400),NR(40),AX(400),AY(400),AZ(400), 1Y(400),TAS(400),ANG(400),PHX(400),PHY(400),PHZ(400),INDI(400) COMMON/SOUR/ROS,VPS,VSS C C *** mode=0 call serv(mode,lin,lou,llu,ldum1,ldum2) if(mode.eq.0)lin=5 if(mode.eq.0)lou=6 if(mode.eq.0)CALL PLOTS(ldum1,ldum2,7) CALL PLOT(5.,5.,-3) C *** C XB = 0. IRUN = 0 READ(lin,106)LU,ISHIFT,IPRINT,ltape WRITE(lou,106)LU,ISHIFT,IPRINT,ltape if(mode.eq.1)lu=llu IF(LU.EQ.0)LU=7 C C *** C *** C REWIND LU IF (ISHIFT.EQ.0)ISHIFT=8 SHIFT=FLOAT(ISHIFT) 200 continue if(ltape.eq.0)READ(LU,101)ICONT,itpr if(ltape.eq.1)READ(LU)ICONT,itpr WRITE(lou,101)ICONT C C *** C *** C IF(ICONT.EQ.0)WRITE(lou,107)LU IF(ICONT.EQ.0)GO TO 99 READ(lin,100)TEXT WRITE(lou,100)TEXT READ(lin,106)NTICX,NTICY,NTICT,NTICA,INDO,INDT,NRAY,IBOUND, 1IRED,IRS,NDX,NDY WRITE(lou,106)NTICX,NTICY,NTICT,NTICA,INDO,INDT,NRAY,IBOUND, 1IRED,IRS,NDX,NDY C C *** C *** C IF(NTICX.EQ.0)GO TO 99 if(itpr.eq.22)ired=0 IF(INDT.EQ.1.OR.INDT.EQ.2)IRED=0 IF(INDT.EQ.0)INDT=3 XB = 0. IF(IBOUND.EQ.0) IBOUND =100 READ(lin,102)XMIN,XMAX,XLEN,DTICX,SC WRITE(lou,102)XMIN,XMAX,XLEN,DTICX,SC IF(ABS(SC).LT..00001)SC=1. IF(ABS(XMAX-XMIN).LT..00001)GO TO 32 XMER = XLEN/(XMAX-XMIN) GLH = 1.5 IF(NTICY.EQ.0)GO TO 32 READ(lin,102)YMIN,YMAX,YLEN,DTICY WRITE(lou,102)YMIN,YMAX,YLEN,DTICY YMER = YLEN/(YMAX-YMIN) C ********************************************************************** CALL COLOR(14) C ********************************************************************** C C PLOTTING OF BORDER FOR RAY DIAGRAM C IF(IRUN.EQ.1)CALL PLOT(XLEN+SHIFT,0.,-3) IRUN=1 72 CALL BORDER(XLEN,DTICX,YLEN,DTICY,SC,TEXT,1,XMIN,XMAX,YMIN,YMAX, 1NTICX,NTICY,NDX,NDY) TX=.5*(XLEN-6.3*SC) CALL SYMBOL(TX,-1.6*SC,.45*SC,'DISTANCE IN KM',0.,14) TX=.5*(YLEN-4.95*SC) U=-(1.6+.4*NDX)*SC CALL SYMBOL(U,TX,.45*SC,'DEPTH IN KM',90.,11) C ********************************************************************** CALL COLOR(2) C ********************************************************************** C C C PLOTTING OF INTERFACES 32 if(ltape.eq.0)READ(LU,101)NINT,(NPNT(I),I=1,NINT) if(ltape.eq.1)READ(LU)NINT,(NPNT(I),I=1,NINT) IF(IPRINT.EQ.3)WRITE(lou,106)NINT,(NPNT(I),I = 1,NINT) IB=IBOUND IF(IBOUND.LT.0)IB=-IBOUND ib=ib+n RD = (XMAX-XMIN)/FLOAT(IB-1) YM = YMAX DO 5 I = 1,NINT N = NPNT(I)-1 if(ltape.eq.0)READ(LU,111)(A(J),B(J),C(J),D(J),X1(J),III(J), 1J=1,N) if(ltape.eq.1)READ(LU)(A(J),B(J),C(J),D(J),X1(J),III(J),J = 1,N) IF(IPRINT.EQ.3)WRITE(lou,105)(A(J),B(J),C(J),D(J),X1(J),III(J), 1J=1,N) IF(NTICY.EQ.0)GOTO 5 MMM=1 IF(IBOUND.LT.0)YM=YM-.06/YMER IF(IBOUND.LT.0)MMM=3 DO 4 M=1,MMM RB=XMIN IF(IBOUND.LT.0)YM=YM+.03/YMER IPL=0 DO 4 J = 1,IB IF(RB.GT.(XMAX+0.01))GOTO 4 DO 1 K = 1,N IF(K.EQ.N) K1 = K IF(RB.GE.X1(K))GOTO 1 K1 = K-1 GOTO 2 1 CONTINUE 2 X2 = RB-X1(K1) X33=X1(K1+1) IF(K1.EQ.N)X33=XMAX IF(XMAX.LT.X33)X33=XMAX X3=X33-RB IF(X3.LT.RD)RB=X33 IF(X3.LT.RD)X2=X33-X1(K1) HXX=YM-(((D(K1)*X2+C(K1))*X2+B(K1))*X2+A(K1)-YMIN) IF(HXX.LT.YMIN.OR.HXX.GT.YMAX)IPL=0 IF(HXX.LT.YMIN.OR.HXX.GT.YMAX)GO TO 4 IF(IPL.NE.0)GO TO 3 IPL=1 XSV=(RB-XMIN)*XMER YSV = HXX*YMER CALL PLOT(XSV,YSV,3) GOTO 4 3 XSV = (RB-XMIN)*XMER YSV = HXX*YMER IF(III(K1).EQ.0.OR.III(K1).EQ.(-1))CALL PLOT(XSV,YSV,2) IF(III(K1).EQ.(-2).OR.III(K1).GT.0)CALL PLOT(XSV,YSV,3) RB = RB+RD if((k1+2).le.n.and.rb.gt.x1(k1+2))rb=x1(k1+2) 4 continue IF(IBOUND.LT.0)YM=YM-0.03/YMER 5 CONTINUE 20 if(ltape.eq.0)READ(LU,102)X0,Y0,ROS,VPS,VSS if(ltape.eq.1)READ(LU)X0,Y0,ROS,VPS,VSS IF(IPRINT.EQ.3)WRITE(lou,102)X0,Y0,ROS,VPS,VSS IF(NTICY.EQ.0)GOTO 21 C C C PLOTTING OF RAYS C C ********************************************************************** CALL COLOR(4) C ********************************************************************** 26 IF(NRAY.NE.0) READ(lin,101)(NR(I),I = 1,NRAY) IF(NRAY.NE.0) WRITE(lou,104)(NR(I),I = 1,NRAY) I = 1 K = 1 21 if(ltape.eq.0)READ(LU,112)N,IND if(ltape.eq.1)READ(LU)N,IND IPL = 0 WRITE(lou,106)N,IND IF(N.EQ.0)GOTO 24 if(ltape.eq.0)READ(LU,113)(X(J),Y(J),J = 1,N) if(ltape.eq.1)READ(LU)(X(J),Y(J),J = 1,N) IF(IPRINT.EQ.3)WRITE(lou,102)(X(J),Y(J),J = 1,N) IF(INDO.NE.0.AND.IND.NE.INDO)GO TO 21 IF(NTICY.EQ.0)GO TO 21 IF(NRAY.EQ.0)GOTO 25 IF(NR(K).EQ.I)GOTO 22 25 DO 10 J = 1,N XX = X(J) YY = Y(J) IF(XX.LT.XMIN.OR.XX.GT.XMAX)GOTO 8 IF(YY.LT.YMIN.OR.YY.GT.YMAX)GOTO 9 IF(IPL.EQ.1)GOTO 6 IF(J.LE.IRS)GO TO 10 IPL = 1 INDEX = 3 GO TO 7 6 INDEX = 2 7 XNEW = (XX-XMIN)*XMER YNEW = (YMAX-(YY-YMIN))*YMER CALL PLOT(XNEW,YNEW,INDEX) GOTO 10 8 IF (IPL.EQ.0) GOTO 10 IF(XX.LT.XMIN) XXX = XMIN IF(XX.GT.XMAX) XXX = XMAX TG=(YY-Y(J-1))/(XX-X(J-1)) YY = TG*(XXX-XX)+YY XX = XXX IPL=0 GOTO 6 9 IF (IPL.EQ.0) GOTO 10 IF(YY.LT.YMIN) YYY=YMIN IF(YY.GT.YMAX) YYY=YMAX TG=(XX-X(J-1))/(YY-Y(J-1)) XX = TG*(YYY-YY)+XX YY = YYY IPL=0 GOTO 6 10 CONTINUE GOTO 23 22 IF(K.GE.NRAY)GOTO 23 K = K+1 23 I = I+1 GOTO 21 24 CONTINUE IF(NTICY.EQ.0)GO TO 11 C ********************************************************************** CALL COLOR(3) C ********************************************************************** XNEW = X0-XMIN XNEW = XNEW*XMER YNEW = YMAX-(Y0-YMIN) YNEW = YNEW*YMER IF(XNEW.LT.0..OR.XNEW.GT.XLEN.OR.YNEW.LT.0..OR.YNEW.GT. 1YLEN) GO TO 33 RD=.3*SC CALL PLOT(XNEW+RD,YNEW+RD,3) CALL PLOT(XNEW,YNEW,2) CALL PLOT(XNEW+RD,YNEW-RD,2) CALL PLOT(XNEW-RD,YNEW-RD,3) CALL PLOT(XNEW,YNEW,2) CALL PLOT(XNEW-RD,YNEW+RD,2) CALL PLOT(XNEW,YNEW,3) 33 CONTINUE C C PLOTTING OF TIME-DISTANCE CURVE C 11 if(ltape.eq.0)READ(LU,112)NS if(ltape.eq.1)READ(LU)NS IF(IPRINT.GE.2)WRITE(lou,106)NS NWTYP=NS IF(NS.LT.0)NS=-NS IF(NS.NE.0.and.ltape.eq.0)READ(LU,114)(INDI(I),X(I),T(I),TAS(I), 1ANG(I),AX(I),AY(I),AZ(I),PHX(I),PHY(I),PHZ(I),I=1,NS) IF(NS.NE.0.and.ltape.eq.1)READ(LU)(INDI(I),X(I),T(I),TAS(I), 1ANG(I),AX(I),AY(I),AZ(I),PHX(I),PHY(I),PHZ(I),I=1,NS) IF(NS.NE.0.AND.IPRINT.GE.2)WRITE(lou,108)(INDI(I),X(I),T(I), 1TAS(I),ANG(I),AX(I),AY(I),AZ(I),PHX(I),PHY(I),PHZ(I),I=1,NS) NSS = NS 35 CONTINUE IF(NTICT.EQ.0)GOTO 15 READ(lin,102)TMIN,TMAX,TLEN,DTICT,VRED WRITE(lou,102)TMIN,TMAX,TLEN,DTICT,VRED IF(IRUN.EQ.1)CALL PLOT(0.,YLEN+SHIFT,-3) IRUN=1 IF(NSS.EQ.0)GOTO 30 IEX=0 if(itpr.ne.22)go to 40 XMER=XLEN/(YMAX-YMIN) DTICX=DTICY XMIN=YMIN XMAX=YMAX NTICX=NTICY 40 CONTINUE YMER = TLEN/(TMAX-TMIN) IF(ABS(VRED).LT..00001) VRED = 6. NAUX=3 IF(INDT.EQ.1.OR.INDT.EQ.2)NAUX=5 C C ********************************************************************** CALL COLOR(14) C ********************************************************************** C CALL BORDER(XLEN,DTICX,TLEN,DTICT,SC,TEXT,0,XMIN,XMAX,TMIN, 1TMAX,NTICX,NTICT,NDX,NDY) TX=.5*(XLEN-6.3*SC) if(itpr.ne.22) 1CALL SYMBOL(TX,-1.6*SC,.45*SC,'DISTANCE IN KM',0.,14) if(itpr.eq.22) 1CALL SYMBOL(TX,-1.6*SC,.45*SC,'DEPTH IN KM',0.,11) TX=.5*(YLEN-8.1*SC) U=-(1.6+.4*NDX)*SC IF(IRED.EQ.0) 1CALL SYMBOL(U,TX,.45*SC,'TRAVEL TIME IN SEC',90.,18) IF(IRED.EQ.0)GO TO 27 CALL SYMBOL(U,TX,.45*SC,'T-D/ ',90.,5) TX=TX+1.8*SC CALL NUMBER(U,TX,.45*SC,VRED,90.,2) TX=TX+2.7*SC CALL SYMBOL(U,TX,.45*SC,'(IN SEC)',90.,8) 27 CONTINUE C C ********************************************************************** CALL COLOR(4) C ********************************************************************** C INDEX = 9 12 DO 13 I = 1,NS IF(IEX.EQ.0.AND.INDI(I).NE.INDT)GO TO 13 XNEW = X(I) IF(IEX.EQ.1)XNEW=XZ(I) IF(XNEW.LT.XMIN.OR.XNEW.GT.XMAX)GOTO 13 YNEW=T(I) IF(IRED.NE.0)YNEW=T(I)-ABS(XNEW-X0)/VRED XNEW = (XNEW-XMIN)*XMER IF(YNEW.LT.TMIN.OR.YNEW.GT.TMAX)GOTO 13 YNEW = (YNEW-TMIN)*YMER CALL SYMBOL(XNEW,YNEW,.15*sc,char(INDEX),0.,-index) 13 CONTINUE IF(IEX.EQ.0)GOTO 30 NS = NSS GOTO 14 30 READ(lin,101)NEXP WRITE(lou,104)NEXP IF(NEXP.EQ.0)GOTO 14 C C ********************************************************************** CALL COLOR(2) C ********************************************************************** C NS = NEXP READ(lin,102)(XZ(I),T(I),I=1,NS) WRITE(lou,102)(XZ(I),T(I),I=1,NS) IF(NSS.EQ.0)GO TO 15 IEX = 1 INDEX = 2 GOTO 12 14 CONTINUE CALL PLOT(0.,-YLEN-SHIFT,-3) C C C PLOTTING OF AMPLITUDE-DISTANCE CURVE C 15 IF(NTICA.EQ.0)GO TO 200 IRUN1=0 ALBACK=0. 19 READ(lin,109)AMIN,AMAX,ALEN,DTICA,FREQ,KABS,ICOMP,MSOUR WRITE(lou,109)AMIN,AMAX,ALEN,DTICA,FREQ,KABS,ICOMP,MSOUR IF(ALEN.LT..00001)CALL PLOT(0.,-ALBACK,-3) IF(ALEN.LT..00001)GO TO 200 CALL SOURCE(lin,lou,0,0,MSOUR,0.,ANGLE,AMSOUR,PHSOUR) IF(KABS.EQ.0)GO TO 38 38 IF(NSS.EQ.0)GO TO 36 IF(INDT.EQ.4)GO TO 36 IF(IRUN.EQ.1.AND.IRUN1.EQ.0)CALL PLOT(XLEN+SHIFT,0.,-3) IF(IRUN1.EQ.1)CALL PLOT(0.,ALEN+SHIFT,-3) IF(IRUN1.EQ.1)ALBACK=ALBACK+ALEN+SHIFT IRUN1=1 IRUN=1 IEX=0 YMER=ALEN/(AMAX-AMIN) NAUX=2 IF(INDT.EQ.1.OR.INDT.EQ.2)NAUX=4 C C ********************************************************************** CALL COLOR(14) C ********************************************************************** C CALL BORDER(XLEN,DTICX,ALEN,DTICA,SC,TEXT,0,XMIN,XMAX,AMIN, 1AMAX,NTICX,NTICA,NDX,NDY) TX=.5*(XLEN-6.3*SC) if(itpr.ne.22) 1CALL SYMBOL(TX,-1.6*SC,.45*SC,'DISTANCE IN KM',0.,14) if(itpr.eq.22) 1CALL SYMBOL(TX,-1.6*SC,.45*SC,'DEPTH IN KM',0.,11) TX=.5*(ALEN-7.65*SC) U=-(1.6+.4*NDX)*SC CALL SYMBOL(U,TX,.45*SC,'A M P L I T U D E',90.,17) IF(ICOMP.EQ.0) 1CALL SYMBOL(.45*SC,ALEN+SC,.45*SC,'VERTICAL',0.,8) IF(ICOMP.EQ.1) 1CALL SYMBOL(.45*SC,ALEN+SC,.45*SC,'RADIAL',0.,6) IF(ICOMP.EQ.2) 1CALL SYMBOL(.45*SC,ALEN+SC,.45*SC,'TRANSVERSE',0.,10) C C ********************************************************************** CALL COLOR(13) C ********************************************************************** C 28 INDEX=9 16 DO 17 I = 1,NS IF(IEX.EQ.0.AND.INDI(I).NE.INDT)GO TO 17 XNEW = X(I) YNEW=AZ(I) IF (ICOMP.EQ.1)YNEW=AX(I) IF (ICOMP.EQ.2)YNEW=AY(I) MWAVE=1 IF(NWTYP.LT.0)MWAVE=2 IF(NWTYP.LT.0.AND.ICOMP.EQ.2)MWAVE=3 C C COMPUTATION OF SOURCE EFFECTS C ***************************** ANGLE=ANG(I) CALL SOURCE(lin,lou,1,MWAVE,MSOUR,0.,ANGLE,AMSOUR,PHSOUR) YNEW=YNEW*AMSOUR C ***************************** C IF(IEX.EQ.0.OR.NEXP.EQ.0)GO TO 41 XNEW=XZ(I) YNEW=T(I) GO TO 31 C C COMPUTATION OF ABSORPTION EFFECTS C ********************************* 41 IF(KABS.GT.0)TAST=TAS(I) IF(KABS.GT.0)YNEW=YNEW*EXP(-3.1415926*FREQ*TAST) C ************************************************** C IF(IPRINT.EQ.1)WRITE(lou,110)X(I),YNEW 31 IF(XNEW.LE.XMIN.OR.XNEW.GE.XMAX)GO TO 17 XNEW=(XNEW-XMIN)*XMER IF(ABS(YNEW).LT.1E-10)GO TO 17 YNEW = ALOG10(ABS(YNEW)) IF(YNEW.LT.AMIN.OR.YNEW.GT.AMAX)GOTO 17 YNEW=(YNEW-AMIN)*YMER CALL SYMBOL(XNEW,YNEW,.15*sc,char(INDEX),0.,-index) 17 CONTINUE 36 IF(IEX.EQ.1)GOTO 18 READ(lin,101)NEXP WRITE(lou,104)NEXP IF(NEXP.EQ.0)GOTO 18 C C ********************************************************************** CALL COLOR(2) C ********************************************************************** C NS = NEXP READ(lin,102) (XZ(I),T(I),I=1,NS) WRITE(lou,102)(XZ(I),T(I),I=1,NS) IF(NSS.EQ.0)GO TO 18 IF(INDT.EQ.1.OR.INDT.EQ.2.OR.INDT.EQ.4)GO TO 18 IEX=1 INDEX = 2 GOTO 16 18 IF(IEX.EQ.0)GO TO 29 NS=NSS 29 CONTINUE C C GO TO 19 C C 100 FORMAT(A) 101 FORMAT(26I3) 102 FORMAT(8F10.5) 103 FORMAT(2X,I2,3(2F7.2,E10.3)) 104 FORMAT(2X,26I3) 105 FORMAT(5E12.6,I5) 106 FORMAT(16I5) 107 FORMAT(2X,'END OF FILE',I3) 108 FORMAT(I5,4F10.5,3E15.9,3F10.5) 109 FORMAT(5F10.5,4I5) 110 FORMAT(F10.5,E15.9) 111 format(5e15.5,i5) 112 format(2i5) 113 format(2e15.5) 114 format(i5,10e15.5) C 99 CONTINUE C C *** C *** C CALL PLOT(0.,0.,999) STOP END C C