C
C P R O G R A M S E I S P L O T C ******************************* C C PROGRAM SEISPLOT IS DESIGNED FOR THE PLOTTING OF SYNTHETIC C SEISMOGRAMS STORED IN THE FILE GENERATED BY PROGRAM SYNTAN C C ************************************************************ C CHARACTER*80 TEXT,PSTEXT,FILEIN,FILEOU,FILE1 DIMENSION SEIS(3001),IEP(100) C C************************************************** C LIN=5 LOU=6 LU4=1 FILEIN='seispl.dat' FILEOU='seispl.out' FILE1='lu4.in' WRITE(*,'(2A)') ' (SEISPL) SPECIFY NAMES OF INPUT AND OUTPUT', 1' FILES LIN, LOU, LU4: ' READ(*,*) FILEIN,FILEOU,FILE1 IF(FILE1.EQ.' ') GO TO 99 OPEN(LIN,FILE=FILEIN,FORM='FORMATTED',STATUS='OLD') OPEN(LOU,FILE=FILEOU,FORM='FORMATTED') OPEN(LU4,FILE=FILE1,FORM='FORMATTED',STATUS='OLD') C C************************************************** C IRUN=0 PSTEXT=' ' IPRINT=0 XSHIFT=3. YSHIFT=6. READ(LIN,*)IPRINT,XSHIFT,YSHIFT,PSTEXT WRITE(LOU,106)IPRINT,XSHIFT,YSHIFT,PSTEXT C IF(IPRINT.LT.0)THEN CALL PLOTN(PSTEXT,0) IPRINT=-IPRINT END IF CALL PLOTS(LDUM1,LDUM2,7) CALL PLOT(XSHIFT,YSHIFT,-3) C 2 MCONT=0 MEPIC=0 NTICX=1 NTICX=1 NDX=0 NDY=1 READ(LIN,*)MCONT,MEPIC,NTICX,NTICY,NDX,NDY WRITE(LOU,101)MCONT,MEPIC,NTICX,NTICY,NDX,NDY IF(MCONT.EQ.0)GO TO 99 IF(MEPIC.EQ.0)GO TO 3 READ(LIN,*)NEPIC,(IEP(I),I=1,NEPIC) WRITE(LOU,101)NEPIC,(IEP(I),I=1,NEPIC) 3 CONTINUE READ(LIN,*)XMIN,XMAX,XLEN,DTICX,YMIN,YMAX,YLEN,DTICY WRITE(LOU,102)XMIN,XMAX,XLEN,DTICX,YMIN,YMAX,YLEN,DTICY AMP=0. B1=1. EPICS=10. EPS=0. SC=1. READ(LIN,*)AMP,B1,EPICS,EPS,SC WRITE(LOU,102)AMP,B1,EPICS,EPS,SC IF(LU4.NE.0)REWIND LU4 READ(LU4,100)TEXT WRITE(LOU,100)TEXT READ(LU4,105)MDIST,MRED,MCOMP,ITPR,VRED,RSTEP,XSOUR,YSOUR,DT WRITE(LOU,105)MDIST,MRED,MCOMP,ITPR,VRED,RSTEP,XSOUR,YSOUR,DT READ(LU4,104)XMX,SMAXIM WRITE(LOU,104)XMX,SMAXIM IF(ABS(EPICS).LT.0.00001)EPICS=10. IF(ABS(B1).LT.0.00001)B1=1. C C PLOT OF FRAME XMER=XLEN/(XMAX-XMIN) YMER=YLEN/(YMAX-YMIN) DDX=RSTEP*XMER IF(IRUN.NE.0)CALL PLOT(XLEN+XSHIFT,0.,-3) IRUN=1 CALL BORDER(XLEN,DTICX,YLEN,DTICY,SC,TEXT,0,XMIN,XMAX, 1YMIN,YMAX,NTICX,NTICY,NDX,NDY) T=.5*(XLEN-6.3*SC) IF(ITPR.NE.22) 1CALL SYMBOL(T,-1.6*SC,.45*SC,'DISTANCE IN KM',0.,14) IF(ITPR.EQ.22) 1CALL SYMBOL(T,-1.6*SC,.45*SC,'DEPTH IN KM',0.,11) T=.5*(YLEN-8.1*SC) U=-(1.6+.4*NDX)*SC IF(MRED.EQ.0) 1CALL SYMBOL(U,T,.45*SC,'TRAVEL TIME IN SEC',90.,18) IF(MRED.EQ.0)GO TO 4 CALL SYMBOL(U,T,.45*SC,'T-D/ ',90.,5) T=T+1.8*SC CALL NUMBER(U,T,.45*SC,VRED,90.,2) T=T+2.7*SC CALL SYMBOL(U,T,.45*SC,'(IN SEC)',90.,8) 4 CONTINUE IF(MCOMP.EQ.0) 1CALL SYMBOL(.45*SC,YLEN+SC,.45*SC,'VERTICAL',0.,8) IF(MCOMP.EQ.1) 1CALL SYMBOL(.45*SC,YLEN+SC,.45*SC,'X-COMPONENT',0.,11) IF(MCOMP.EQ.2) 1CALL SYMBOL(.45*SC,YLEN+SC,.45*SC,'Y-COMPONENT',0.,11) T=XLEN-7.5*SC CALL NUMBER(T,YLEN+.5*SC,.3*SC,AMP,0.,0) T=T+1.5*SC CALL NUMBER(T,YLEN+.5*SC,.3*SC,B1,0.,2) T=T+1.5*SC CALL NUMBER(T,YLEN+.5*SC,.3*SC,EPS,0.,1) T=T+1.5*SC CALL NUMBER(T,YLEN+.5*SC,.3*SC,SMAXIM,0.,5) CALL PLOT(0.,0.,3) C C LOOP FOR THE RECEIVER POSITIONS C DO 10 I=1,MDIST READ(LU4,110)XX,SMAXI,TMIN,NPTS READ(LU4,109)(SEIS(M),M=1,NPTS) IF(I.EQ.1)SMAX1=SMAXI SAUX=SMAXI/999. DO 22 M=1,NPTS 22 SEIS(M)=SEIS(M)*SAUX IF(XX.LE.XMIN.OR.XX.GE.XMAX)GO TO 10 IF(MEPIC.EQ.0)GO TO 5 DO 6 J=1,NEPIC IF(I.EQ.IEP(J))GO TO 5 6 CONTINUE GO TO 10 C 5 IF(SMAXI.LT.0.000001)GO TO 7 IF(ABS(AMP).LT.0.00001)FACTOR=B1*DDX/SMAXI IF(ABS(AMP).LT.0.00001)GO TO 21 IF(ABS(EPS).GT.0.00001)GO TO 20 IF(AMP.LT.(-0.00001))FACTOR=B1*DDX/SMAXIM IF(AMP.GT.0.00001.AND.AMP.LT.5.)FACTOR=B1 IF(AMP.GT.5.)FACTOR=B1*DDX/SMAX1 SF1=.003*SFMAX GO TO 21 20 IF(AMP.LT..00001)FACTOR=B1*DDX*((ABS(XX-XSOUR)/EPICS)**EPS) 1/SMAXIM IF(AMP.GT.0.00001)FACTOR=B1*(ABS(XX-XSOUR)/EPICS)**EPS 21 CONTINUE GO TO 8 7 FACTOR=0. 8 CONTINUE SFMAX=FACTOR*SMAXI SF1=.003*SFMAX IF(IPRINT.EQ.1)WRITE(LOU,103)XX,SMAXI,FACTOR,SFMAX C C X0=(XX-XMIN)*XMER XNEW=X0 AMPL=0. YNEW=0. ISTART=1 IF(TMIN.GE.YMIN)GO TO 12 IAUX=(YMIN-TMIN)/DT+1 TL=TMIN+DT*FLOAT(IAUX-1) AMPL=SEIS(IAUX)+(SEIS(IAUX+1)-SEIS(IAUX))*(YMIN-TL)/DT XNEW=X0-FACTOR*AMPL IF(XNEW.LT.0..OR.XNEW.GT.XLEN)GO TO 15 CALL PLOT(XNEW,YNEW,3) 15 ISTART=IAUX+1 12 CONTINUE IF(ISTART.EQ.1)CALL PLOT(XNEW,YNEW,3) IF(ISTART.GT.NPTS)CALL PLOT(X0,YLEN,2) IF(ISTART.GT.NPTS)GO TO 10 S2=FACTOR*SEIS(ISTART) S3=FACTOR*SEIS(ISTART+1) DO 11 J=ISTART,NPTS IF(J.EQ.ISTART)GO TO 14 S1=S2 S2=S3 IF(J.EQ.NPTS)GO TO 14 S3=FACTOR*SEIS(J+1) IF(ABS(S1).LT.SF1.AND.ABS(S2).LT.SF1.AND.ABS(S3).LT.SF1) 1GO TO 11 14 XNEW=X0-S2 YNEW=(TMIN+DT*FLOAT(J-1)-YMIN)*YMER IF(YNEW.GT.YLEN)GO TO 13 IF(XNEW.LT.0..OR.XNEW.GT.XLEN)GO TO 11 CALL PLOT(XNEW,YNEW,2) GO TO 11 13 AMPL=SEIS(J-1)+(SEIS(J)-SEIS(J-1))*(YMAX-TMIN-DT*FLOAT(J-1))/DT XNEW=X0-FACTOR*AMPL IF(XNEW.LT.0..OR.XNEW.GT.XLEN)GO TO 10 CALL PLOT(XNEW,YLEN,2) GO TO 10 11 CONTINUE CALL PLOT(X0,YLEN,2) 10 CONTINUE C C END OF THE LOOP FOR RECEIVER POSITIONS C GO TO 2 C C 100 FORMAT(A) 101 FORMAT(16I5) 102 FORMAT(8F10.5) 103 FORMAT(2X,4E15.5) 104 FORMAT(22X,F10.5,9X,E15.9) 105 FORMAT(4I5,5F10.5) 106 FORMAT(I5,2F10.5,1X,A) 109 FORMAT(20F4.0) 110 FORMAT(F10.5,E15.8,F10.5,I5) 99 CALL PLOT(0.,0.,999) C STOP END C C======================================================================= C INCLUDE 'border.for' C border.for INCLUDE 'error.for' C error.for INCLUDE 'calcops.for' C calcops.for C C======================================================================= C