Commit 7eef93ba authored by thomas.forbriger's avatar thomas.forbriger Committed by thomas.forbriger
Browse files

- introduced new scaling option -So

This is a legacy commit from before 2015-03-01.
It may be incomplete as well as inconsistent.
See COPYING.legacy and README.history for details.
- reviewed code to get rid of all the compiler warnings


SVN Path:     http://gpitrsvn.gpi.uni-karlsruhe.de/repos/TFSoftware/trunk
SVN Revision: 5300
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent bc8e6f38
......@@ -87,7 +87,7 @@ REFSUB=refract_readdata.o refract_skipdata.o refract_setdefaults.o \
refract_varplot.o refract_pgparameters.o refract_ttreduce.o \
refract_message.o refract_dopicks.o refract_domodel.o refract_usage.o \
refract_cmdopt.o refract_selfilestyle.o refract_preread.o \
refract_pgdefaults.o refract_vpframe.o
refract_pgdefaults.o refract_vpframe.o refract_plotoffset.o
REFOBS=refract.o $(addprefix sub/, $(REFSUB))
# Fortran dependencies
......
......@@ -31,6 +31,7 @@ c 20/11/12 V1.4 provide file specific variable area plot flag
c store field offset explicitely
c support plotting of a baseline
c 26/04/2013 V1.5 increased number of characters in file name
c 24/10/2013 V1.6 added comment on offset arrays
c
c==============================================================================
c
......@@ -55,6 +56,10 @@ c roffset: to locate trace in plot panel
c fieldoffset: offset of receiver in field profile
c
c both values will be equal, except if trace is shifted intentionally
c fieldoffset: source to receiver offset as defined in data file
c this is used for offset dependent scaling as well as
c for travel time reduction
c roffset: source to receiver offset to be used for ordinate axis
real roffset(maxtraces), fieldoffset(maxtraces)
c
real maxval(maxtraces), average(maxtraces), minval(maxtraces)
......
......@@ -29,6 +29,7 @@ c 29/07/00 V1.2 introduced opt_Tannotate
c 26/11/10 V1.3 support additional file formats
c 12/11/2012 V1.4 optionally do not apply additional travel time
c reduction to offset shifted traces
c 24/10/2013 V1.5 added ordinate switch
c
c==============================================================================
c
......@@ -51,16 +52,16 @@ c elements and style
logical opt_ECpicks, opt_ECwave, opt_ECtt
c
c file reading
character*80 opt_Fpicks
character*80 opt_Farrival
character*80 opt_Ftaper
character*80 opt_Fmodel
character*80 opt_Fformat
character*120 opt_Fpicks
character*120 opt_Farrival
character*120 opt_Ftaper
character*120 opt_Fmodel
character*120 opt_Fformat
c
c scaling
real opt_Sxmin, opt_Sxmax, opt_Stmin, opt_Stmax
real opt_Sexp, opt_Samp, opt_Sclip, opt_Svel, opt_Sminoff, opt_Sradius
integer opt_Smode
integer opt_Smode, opt_Sordinate
logical opt_Sinv, opt_Savg, opt_Sxrange, opt_Strange, opt_Sreduce
logical opt_Sosnoreduce
c
......@@ -74,7 +75,7 @@ c common blocks
& opt_Sxmin, opt_Sxmax, opt_Stmin, opt_Stmax,
& opt_Sexp, opt_Samp, opt_Sclip, opt_Svel,
& opt_Sminoff, opt_Sradius, opt_Tmodx, opt_Tmodt,
& opt_Lttwidth
& opt_Lttwidth, opt_Sordinate
common /refract_optL/ opt_Tmode, opt_Tlegend, opt_Tmodel, opt_Lcycle,
& opt_Ccycle, opt_Cswap, opt_Egrid, opt_Ewiggle,
& opt_Ebubble, opt_Epicks, opt_Ewave, opt_Ett,
......
......@@ -66,17 +66,17 @@ c line width for synthetic travel time curves
integer pg_syntt_lw
c
c program title
character*100 pg_title
character*120 pg_title
c
c axis labels
character*100 pg_xlabel
character*100 pg_ylabel
character*120 pg_xlabel
character*120 pg_ylabel
c
c actual pmmode
character*20 pg_pmmode
c
c actual pickmode
character*20 pg_pickmode
character*30 pg_pickmode
c
c common blocks
common /refr_pgpara/ pg_maindevice
......
......@@ -51,6 +51,7 @@ c 26/11/2010 V4.8 provide additional input formats
c 15/11/2011 V4.8a this version does safe amplitude scaling even for
c unusual cases (see refract_setscale.f)
c 20/11/2012 V4.9 several new plot style options are implemented
c 24/10/2013 V4.10 added alternative definitions of ordinate scale
c
c==============================================================================
c
......@@ -58,7 +59,7 @@ c
c
character*79 version
parameter(version=
& 'REFRACT V4.9 REFRACTion seismics - data interpretation')
& 'REFRACT V4.10 REFRACTion seismics - data interpretation')
c
c get common blocks
include 'refract_dim.inc'
......
......@@ -36,6 +36,7 @@ c 14/11/2011 V1.8 remember whether minoff is forced
c 12/11/2012 V1.9 new option -Sn
c 13/11/2012 V1.10 new option -Ef and -TL
c 20/11/2012 V1.11 new option -Eu
c 24/10/2013 V1.12 new option -So
c
c==============================================================================
c
......@@ -65,17 +66,17 @@ c CVS Id
& '$Id$')
c commandline
integer maxopt
parameter(maxopt=64)
parameter(maxopt=65)
character*3 optid(maxopt)
character*120 optarg(maxopt)
logical optset(maxopt), opthasarg(maxopt)
c here are the keys to our commandline options
c old command line options
data (optid(i), i=1,15)/2h-D,2h-d,2h-v,2h-p,2h-C,2h-L,
& 2h-M,2h-e,2h-R,2h-O,2h--,
& 2h--,2h--,2h--,2h--/
data (optid(i), i=1,15)/'-D','-d','-v','-p','-C','-L',
& '-M','-e','-R','-O','--',
& '--','--','--','--'/
data (opthasarg(i), i=1,15)/.FALSE.,.TRUE.,4*.FALSE.,9*.TRUE./
data (optarg(i),i=1,15) /1h-,3hx11,4*1h-,1h1,2h0.,7*3h-1./
data (optarg(i),i=1,15) /'-','x11',4*'-','1','0.',7*'-1.'/
c titles, labels, legends
data (optid(i), i=16,22) /'-Tt','-Tx','-Ty','-Tm','-Tl',
& '-Ts','-TM'/
......@@ -126,6 +127,9 @@ c seismograms scaling
data optid(61) /'-Sn'/
data opthasarg(61) /.FALSE./
data optarg(61) /'-'/
data optid(65) /'-So'/
data opthasarg(65) /.TRUE./
data optarg(65) /'0'/
c
c additionals
data (optid(i), i=55,56) /'-Lt','-Ta'/
......@@ -207,6 +211,9 @@ c seismogram scaling
read(optarg(54), *) opt_Sradius
plflag_hypoffset=optset(57)
opt_Sosnoreduce=optset(61)
read(optarg(65), *) opt_Sordinate
if ((opt_Sordinate.lt.0).or.(opt_Sordinate.gt.3))
& stop 'ERROR: argument to -So is out of range'
c
c titles, label, legends
opt_Ttitle=version
......@@ -284,7 +291,7 @@ c
c
return
c the following line prevents the linker from removing the ID string
99 print *, refract_cmdopt_id
print *, refract_cmdopt_id
end
c
c ----- END OF refract_cmdopt.f -----
......@@ -120,9 +120,12 @@ c
integer i,j,k
real t, ttot, x, xtot
double precision sqalpha
double precision range
double precision therange
logical rangeok
real redtime, redx, redy,realtmax
c
therange=1.
sqalpha=1.
c
if (.not.((mod_valid).and.(elem_syntt))) return
c save settings
......@@ -166,41 +169,41 @@ c now reflected at bottom of layer i
call pgmove(redx,x)
c first off all check for a good alpha-range
rangeok=.FALSE.
range=1.
therange=1.
c do this as often as range is not ok
do while (.not.(rangeok))
j=1
xtot=0.
ttot=0.
do while ((xtot.lt.tov_rmax).and.(ttot.lt.realtmax).and.(j.lt.100))
sqalpha=float(j)*range/100.
sqalpha=float(j)*therange/100.
xtot=0.
ttot=0.
c go through all layers
do k=1,i
x=2*mod_thick(k)*
& sqrt(1./(((mod_slo(k)**2)/(sqalpha*mod_slo(1)**2))-1.))
t=2*mod_thick(k)*mod_slo(k)*
& sqrt(1./(1.-((sqalpha*mod_slo(1)**2)/(mod_slo(k)**2))))
x=sngl(2*mod_thick(k)*
& sqrt(1./(((mod_slo(k)**2)/(sqalpha*mod_slo(1)**2))-1.)))
t=sngl(2*mod_thick(k)*mod_slo(k)*
& sqrt(1./(1.-((sqalpha*mod_slo(1)**2)/(mod_slo(k)**2)))))
xtot=xtot+x
ttot=ttot+t
enddo
j=j+1
enddo
range=sqalpha
therange=sqalpha
if (j.gt.80) rangeok=.TRUE.
enddo
c go through all ray-angles
do j=1,100
sqalpha=float(j)*range/100.
sqalpha=float(j)*therange/100.
xtot=0.
ttot=0.
c go through all layers
do k=1,i
x=2*mod_thick(k)*
& sqrt(1./(((mod_slo(k)**2)/(sqalpha*mod_slo(1)**2))-1.))
t=2*mod_thick(k)*mod_slo(k)*
& sqrt(1./(1.-((sqalpha*mod_slo(1)**2)/(mod_slo(k)**2))))
x=sngl(2*mod_thick(k)*
& sqrt(1./(((mod_slo(k)**2)/(sqalpha*mod_slo(1)**2))-1.)))
t=sngl(2*mod_thick(k)*mod_slo(k)*
& sqrt(1./(1.-((sqalpha*mod_slo(1)**2)/(mod_slo(k)**2)))))
xtot=xtot+x
ttot=ttot+t
enddo
......@@ -235,7 +238,7 @@ c
real charsize, value, depth, fac, xcor, ycor
integer i,j,colind, nc
integer headlen(4)
data head/5hlayer,5hdepth,9hthickness,8hvelocity/
data head/'layer','depth','thickness','velocity'/
data headlen/5,5,9,8/
c
if (.not.((mod_valid).and.(elem_modbox))) return
......@@ -387,6 +390,8 @@ c
parameter(lu=10)
real depth, depthold, velocity
c
depthold=0.
c
if ((mod_valid).and.((elem_modbox).or.(elem_syntt))) flag_replot=.true.
mod_valid=.true.
c
......
......@@ -58,7 +58,7 @@ c prefer blue over green
c
return
c the following line prevents the linker from removing the ID string
99 print *, refract_pgdefaults_id
print *, refract_pgdefaults_id
end
c
c ----- END OF refract_pgdefaults.f -----
......@@ -39,7 +39,7 @@ c
include 'refract_seipar.inc'
c
integer i
real xbox(4), ybox(4), relheight
real xbox(4), ybox(4)
real xsep, ysep, xpos, ypos
real purexsep, pureysep, maxheight
real scalfac
......
......@@ -56,10 +56,10 @@ c
invers=1
nc=1
if (plflag_bubbles) nc=2
if (plflag_invers) invers=invers*-1
if (plflag_invers) invers= -1*invers
c in case of bubbles do plotting twice with reversed sign
do bc=1,nc
invers=invers*-1
invers= -1*invers
reverse=.false.
if (invers.gt.0) reverse=.true.
if (settracevp(i,reverse)) then
......
c this is <refract_plotoffset.f>
c ----------------------------------------------------------------------------
c ($Id$)
c
c Copyright (c) 2013 by Thomas Forbriger (BFO Schiltach)
c
c retunr plot offset (ordinate)
c
c REVISIONS and CHANGES
c 24/10/2013 V1.0 Thomas Forbriger
c
c ============================================================================
c
real function plotoffset(itrace)
c
integer itrace
c
include 'refract_dim.inc'
include 'refract_data.inc'
include 'refract_para.inc'
c
real theoffset
c
theoffset=roffset(itrace)
if (plflag_osnoreduce) theoffset=fieldoffset(itrace)
c
plotoffset=theoffset
return
end
c
c ----- END OF refract_plotoffset.f -----
......@@ -71,7 +71,7 @@ c taper file
c
return
c the following line prevents the linker from removing the ID string
99 print *, refract_preread_id
print *, refract_preread_id
end
c
c ----- END OF refract_preread.f -----
......@@ -41,6 +41,7 @@ c 12/11/2012 V1.9 store offset shift
c 20/11/2012 V1.10 read variable offset flag
c store field offset, not offset shift
c read 'plot baseline' flag
c 24/10/2013 V1.11 added alternative definitions of ordinate scale
c
c==============================================================================
c
......@@ -65,8 +66,8 @@ c
c some helpfull things
integer i, iargc, ierr, lu, j, allnsamples, k
parameter(lu=10)
character*80 infile
character*80 fileformat
character*120 infile
character*120 fileformat
character*240 selection
logical useselect, hot, moreflags
c
......@@ -265,12 +266,22 @@ c extract info
instype(ntraces)=wid2line(89:94)
if (plflag_hypoffset) then
roffset(ntraces)=
& sffu_offset(scs,sc1,sc2,sc3,rcs,rc1,rc2,rc3)
& sffu_offset(scs,sc1,sc2,sc3,rcs,rc1,rc2,rc3)
else
roffset(ntraces)=
& sffu_offset(scs,sc1,sc2,0.,rcs,rc1,rc2,0.)
& sffu_offset(scs,sc1,sc2,0.,rcs,rc1,rc2,0.)
endif
fieldoffset(ntraces)=roffset(ntraces)
if (opt_Sordinate.eq.1) then
roffset(ntraces)=rc1
elseif (opt_Sordinate.eq.2) then
roffset(ntraces)=rc2
elseif (opt_Sordinate.eq.3) then
roffset(ntraces)=rc3
elseif (opt_Sordinate.ne.0) then
stop 'ERROR (readdata): '//
& 'invalid definition of ordinate'
endif
roffset(ntraces)=roffset(ntraces)+offshift
if (ntraces.eq.1) then
minoffset=roffset(ntraces)
......
......@@ -40,7 +40,8 @@ c
cE
c declare local variables
character*(*) refract_selfilestyle_id
parameter (refract_selfilestyle_id='$Id$')
parameter (refract_selfilestyle_id=
& '$Id$')
c
c------------------------------------------------------------------------------
c go
......@@ -56,7 +57,7 @@ c go
c
return
c the following line prevents the linker from removing the ID string
99 print *, refract_selfilestyle_id
print *, refract_selfilestyle_id
end
c
c ----- END OF refract_selfilestyle.f -----
......@@ -47,18 +47,18 @@ cE
c
integer i
real tmin, tmax, thistmax, rmin, rmax
real redtime
real redtime, plotoffset
c
c find most and least values
rmin=roffset(1)
rmax=roffset(1)
tmin=redtime(toffset(1),roffset(1))
tmax=redtime(toffset(1)+dt(1)*(nsamples(1)-1),roffset(1))
rmin=plotoffset(1)
rmax=plotoffset(1)
tmin=redtime(toffset(1),plotoffset(1))
tmax=redtime(toffset(1)+dt(1)*(nsamples(1)-1),plotoffset(1))
do i=1,ntraces
if (plpar_remav) then
rmin=min(rmin,roffset(i)+max(((minval(i)-average(i))*
rmin=min(rmin,plotoffset(i)+max(((minval(i)-average(i))*
& trv_mpc(i)),-plpar_clip))
rmax=max(rmax,roffset(i)+min(((maxval(i)-average(i))*
rmax=max(rmax,plotoffset(i)+min(((maxval(i)-average(i))*
& trv_mpc(i)),plpar_clip))
else
rmin=min(rmin,roffset(i)+max((minval(i)*
......@@ -67,9 +67,9 @@ c find most and least values
& trv_mpc(i)),plpar_clip))
endif
c
tmin=min(tmin,redtime(toffset(i),roffset(i)))
tmin=min(tmin,redtime(toffset(i),plotoffset(i)))
thistmax=toffset(i)+dt(i)*(nsamples(i)-1)
tmax=max(tmax,redtime(thistmax,roffset(i)))
tmax=max(tmax,redtime(thistmax,plotoffset(i)))
enddo
c
tov_tmin=tmin
......
......@@ -66,7 +66,7 @@ c the baseline of the curve must be 0. or average
c
logical result
real vppm, ttmin, ttmax, theoffset
real realtime
real realtime, plotoffset
c
c factor "world coordinates -> normalized device coordinates"
vppm=(tov_vptop-tov_vpbot)/(tov_rmax-tov_rmin)
......@@ -123,8 +123,7 @@ c
c now check TIME SCALE
ttmin=toffset(i)
ttmax=toffset(i)+(nsamples(i)-1)*dt(i)
theoffset=roffset(i)
if (plflag_osnoreduce) theoffset=fieldoffset(i)
theoffset=plotoffset(i)
trv_tmin=realtime(tov_tmin, theoffset)
trv_tmax=realtime(tov_tmax, theoffset)
if ((ttmin.ge.trv_tmax).or.(ttmax.le.trv_tmin)) result=.false.
......
......@@ -35,6 +35,7 @@ c 12/11/2012 V1.7 new option -Sn
c 20/11/2012 V1.8 new file specific flag v:
c new option -Eu
c new file specific flag b:
c 24/10/2013 V1.9 new option -So
c
c==============================================================================
c
......@@ -57,7 +58,7 @@ c go
print *,' [-Fp file] [-Fa file] [-Ft file] [-Fm file]'
print *,' [-Sx x1,x2] [-St t1,t2] [-Se exp] [-Sa lev]'
print *,' [-Sc lev] [-Sm mode] [-Sr vel] [-Si] [-SM]'
print *,' [-Sn] [-SR radius] [-SO minoff] [-Sh]'
print *,' [-Sn] [-SR radius] [-SO minoff] [-Sh] [-So n]'
print *,' [-C] [-L] [-R radius] [-O minoff]'
print *,' file [t:n,n-n] [o:s] [s:i,s,w] [n:name]'
print *,' [h:h,l,s] [r:r,g,b] [f:format] [v:f]'
......@@ -200,6 +201,15 @@ c
print *,' different receiver locations'
print *,'-Sh offset is distance to hypocenter (rather than'
print *,' epicenter)'
print *,'-So n define ordinate scale:'
print *,' n=0: source to receiver offset (default)'
print *,' n=1: x coordinate'
print *,' n=2: y coordinate'
print *,' n=3: z coordinate'
print *,' in cases where ordinate scales other than'
print *,' source to receiver offset are used together'
print *,' with reduced time scales, the application'
print *,' of option -Sn is recommended.'
print *,' '
print *,'The following options are supported for backward compatibility:'
print *,'---------------------------------------------------------------'
......@@ -316,7 +326,7 @@ c
stop
c
c the following line prevents the linker from removing the ID string
99 print *, refract_usage_id
print *, refract_usage_id
end
c
c----------------------------------------------------------------------
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment