Commit 6d424212 authored by thomas.forbriger's avatar thomas.forbriger Committed by thomas.forbriger
Browse files

started to equip stuplo with libfapidxx interface

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.


SVN Path:     http://gpitrsvn.gpi.uni-karlsruhe.de/repos/TFSoftware/branches/su1
SVN Revision: 3660
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent 068ee2a5
...@@ -79,6 +79,7 @@ c V1.26 02/07/07 provide option to set tick intervals ...@@ -79,6 +79,7 @@ c V1.26 02/07/07 provide option to set tick intervals
c V1.27 18/01/08 do not use write statement for annotations c V1.27 18/01/08 do not use write statement for annotations
c just assign to character variable line c just assign to character variable line
c V1.28 04/12/09 use correct DIN notation for units c V1.28 04/12/09 use correct DIN notation for units
c V1.29 02/01/11 start implementing libfapidxx
c c
c====================================================================== c======================================================================
program stuplo program stuplo
...@@ -89,7 +90,7 @@ c ...@@ -89,7 +90,7 @@ c
c version c version
character*77 version, creator character*77 version, creator
parameter(version= parameter(version=
& 'STUPLO V1.28 plot seismic time series (SFF format)') & 'STUPLO V1.29 plot seismic time series (SFF format)')
parameter(creator='1996 by Thomas Forbriger (IfG Stuttgart)') parameter(creator='1996 by Thomas Forbriger (IfG Stuttgart)')
c parameter definitions c parameter definitions
integer maxsamples, maxselect, lu, maxtraces, maxchain, maxstyle integer maxsamples, maxselect, lu, maxtraces, maxchain, maxstyle
...@@ -109,7 +110,7 @@ c counters ...@@ -109,7 +110,7 @@ c counters
c variables c variables
logical debug, verbose, goahead logical debug, verbose, goahead
character line*80 character line*80
integer ntrim, ntraces, i, n integer ntrim, ntraces, i, n, ierr
c here is the one big array to contain all seismic traces c here is the one big array to contain all seismic traces
c and this big array will hold real and integer data together c and this big array will hold real and integer data together
c the way we do this both real and integer type variables c the way we do this both real and integer type variables
...@@ -121,6 +122,7 @@ c arras to hold information on data ...@@ -121,6 +122,7 @@ c arras to hold information on data
integer nsamples(maxtraces), firstsample(maxtraces) integer nsamples(maxtraces), firstsample(maxtraces)
integer traceinfile(maxtraces) integer traceinfile(maxtraces)
character*80 filename(maxtraces), firstfree(maxtraces) character*80 filename(maxtraces), firstfree(maxtraces)
character*80 informat
character*10 date(maxtraces) character*10 date(maxtraces)
character*12 time(maxtraces) character*12 time(maxtraces)
character*5 station(maxtraces) character*5 station(maxtraces)
...@@ -177,27 +179,31 @@ c variables related to pgplot ...@@ -177,27 +179,31 @@ c variables related to pgplot
real timeax(maxsamples) real timeax(maxsamples)
c commandline c commandline
integer maxopt, lastarg, iargc integer maxopt, lastarg, iargc
parameter(maxopt=36) parameter(maxopt=37)
character*3 optid(maxopt) character*3 optid(maxopt)
character*200 optarg(maxopt) character*200 optarg(maxopt)
logical optset(maxopt), opthasarg(maxopt) logical optset(maxopt), opthasarg(maxopt)
c here are the keys to our commandline options c here are the keys to our commandline options
data optid/2h-d,2h-D,2h-g,2h-c,2h-u,2h-s,2h-i,2h-a,2h-t,2h-f,2h-A,2h-k, data optid/2h-d,2h-D,2h-g,2h-c,2h-u,2h-s,2h-i,2h-a,2h-t,2h-f,2h-A,2h-k,
& 2h-C,2h-Y,2h-R,2h-L,2h-z,2h-m,2h-v,2h-N,2h-l,2h-h,2h-V,2h-X, & 2h-C,2h-Y,2h-R,2h-L,2h-z,2h-m,2h-v,2h-N,2h-l,2h-h,2h-V,2h-X,
& 2h-T,2h-S,2h-E,3h-nT,2h-x,2h-y,2h-W,3h-Fc,3h-oS,3h-wc,3h-xt,3h-nx/ & 2h-T,2h-S,2h-E,3h-nT,2h-x,2h-y,2h-W,3h-Fc,3h-oS,3h-wc,3h-xt,
& 3h-nx,'-ty'/
data opthasarg/.TRUE.,2*.FALSE.,3*.TRUE.,4*.FALSE.,.TRUE.,2*.FALSE., data opthasarg/.TRUE.,2*.FALSE.,3*.TRUE.,4*.FALSE.,.TRUE.,2*.FALSE.,
& 3*.TRUE.,.FALSE.,.TRUE.,2*.FALSE.,2*.TRUE.,.FALSE.,3*.TRUE., & 3*.TRUE.,.FALSE.,.TRUE.,2*.FALSE.,2*.TRUE.,.FALSE.,3*.TRUE.,
& 2*.FALSE.,2*.TRUE.,4*.FALSE.,2*.TRUE./ & 2*.FALSE.,2*.TRUE.,4*.FALSE.,3*.TRUE./
data optarg/3hx11,2*1h-,3hfTt,1h ,1hy,4*1h-,1h*,2*1h-,2h1.,2*2h0.,1h-, data optarg/3hx11,2*1h-,3hfTt,1h ,1hy,4*1h-,1h*,2*1h-,2h1.,2*2h0.,1h-,
& 2h0.,2*1h-,8h1.,1.,1.,11h1.,1.,1.,1.,1h-,2*1h-,2h0.,2*1h-, & 2h0.,2*1h-,8h1.,1.,1.,11h1.,1.,1.,1.,1h-,2*1h-,2h0.,2*1h-,
& 2*5h0.,1.,4*1h-,4h0.,0,4h0,0./ & 2*5h0.,1.,4*1h-,4h0.,0,4h0,0.,'sff'/
c---------------------------------------------------------------------- c----------------------------------------------------------------------
c give basic information and help c give basic information and help
line=' ' line=' '
if (iargc().eq.1) call getarg(1, line) if (iargc().eq.1) call getarg(1, line)
c---------------------------------------------------------------------- c----------------------------------------------------------------------
c give help information c give help information
if ((line(1:5).eq.'-help').or.(iargc().lt.1)) then if (line(1:6).eq.'-xhelp') then
call sff_help_details
stop
elseif ((line(1:5).eq.'-help').or.(iargc().lt.1)) then
print 80,version print 80,version
print *,creator print *,creator
print 80,'Usage: stuplo [-d dev] [-g] [-a] [-i] [-t] [-k] [-N]' print 80,'Usage: stuplo [-d dev] [-g] [-a] [-i] [-t] [-k] [-N]'
...@@ -207,14 +213,16 @@ c give help information ...@@ -207,14 +213,16 @@ c give help information
print 80,' [-l std,lab,cur] [-h std,xlab,ylab,cap]' print 80,' [-l std,lab,cur] [-h std,xlab,ylab,cap]'
print 80,' [-X label] [-T title] [-S sec] [-E]' print 80,' [-X label] [-T title] [-S sec] [-E]'
print 80,' [-nT] [-x f,t] [-y f,t] [-W] [-Fc] [-oS]' print 80,' [-nT] [-x f,t] [-y f,t] [-W] [-Fc] [-oS]'
print 80,' [-wc] [-xt i,n] [-nx n,i]' print 80,' [-wc] [-xt i,n] [-nx n,i] [-ty f]'
print 80,' file [list] [nc:] ...' print 80,' file [list] [nc:] ...'
print 80,'or: stuplo -help' print 80,'or: stuplo -help'
print 80,'or: stuplo -xhelp'
if (iargc().lt.1) stop 'ERROR: missing parameters\n' if (iargc().lt.1) stop 'ERROR: missing parameters\n'
print *,' ' print *,' '
print *,'STUPLO plots seismic time series that are stored' print *,'STUPLO plots seismic time series that are stored'
print *,'in SFF format (Stuttgart File Format).' print *,'in SFF format (Stuttgart File Format).'
print *,' ' print *,' '
print *,'-ty f select input file format (see below)'
print *,'-d dev This option selects the pgplot output' print *,'-d dev This option selects the pgplot output'
print *,' device. Information on available ouput' print *,' device. Information on available ouput'
print *,' devices is given below.' print *,' devices is given below.'
...@@ -373,6 +381,7 @@ c give help information ...@@ -373,6 +381,7 @@ c give help information
print *,' maximum number of chains to build:',maxchain print *,' maximum number of chains to build:',maxchain
print *,' maximum number of different plot styles:',maxstyle print *,' maximum number of different plot styles:',maxstyle
print *,' ' print *,' '
call sff_help_formats
stop stop
endif endif
c---------------------------------------------------------------------- c----------------------------------------------------------------------
...@@ -441,6 +450,7 @@ c first read the commandline ...@@ -441,6 +450,7 @@ c first read the commandline
optcleancaprect=optset(34) optcleancaprect=optset(34)
read(optarg(35), *, end=96, err=97) majorxticks, nminorxticks read(optarg(35), *, end=96, err=97) majorxticks, nminorxticks
read(optarg(36), *, end=96, err=97) nmajorxticks, minorxticks read(optarg(36), *, end=96, err=97) nmajorxticks, minorxticks
informat=optarg(37)
c device='/krm3' c device='/krm3'
c---------------------------------------------------------------------- c----------------------------------------------------------------------
c initialize c initialize
...@@ -471,9 +481,10 @@ c is there a new chain to start ...@@ -471,9 +481,10 @@ c is there a new chain to start
if (nchain.gt.maxchain) stop 'ERROR: opened too many chains' if (nchain.gt.maxchain) stop 'ERROR: opened too many chains'
goto 4 goto 4
endif endif
call sff_TrimLen(infile,ntrim) ntrim=index(infile,' ')-1
if (verbose) print 81,' opening data file ',infile(1:ntrim) if (verbose) print 81,' opening data file ',infile(1:ntrim)
open(lu, file=infile, err=99, status='old') call sff_select_input_format(informat, ierr)
if (ierr.ne.0) stop 'ERROR: selecting input file format'
call sffopen(lu, filep, useselect, selection, maxselect, debug) call sffopen(lu, filep, useselect, selection, maxselect, debug)
ftrace=0 ftrace=0
c start trace loop c start trace loop
...@@ -1064,7 +1075,7 @@ c declare parameters ...@@ -1064,7 +1075,7 @@ c declare parameters
c declare variables c declare variables
integer ierr, i integer ierr, i
real sffversion real sffversion
character timestamp*13, code*20, line*80 character timestamp*13, code*20, line*80, filename*80
c go c go
c evaluate trace selections c evaluate trace selections
call getarg(filep+1, line) call getarg(filep+1, line)
...@@ -1088,27 +1099,11 @@ c evaluate trace selections ...@@ -1088,27 +1099,11 @@ c evaluate trace selections
else else
useselect=.false. useselect=.false.
endif endif
call getarg(filep, filename)
c read file header and ignore optional blocks c read file header and ignore optional blocks
call sff_RStatus(lu,sffversion,timestamp,code,ierr) call sff_ROpen(lu, filename, sffversion,timestamp,code,ierr)
if (debug) print *,'DEBUG: read status' if (ierr.ne.0) stop 'ERROR: opening file'
if (ierr.ne.0) stop 'ERROR: reading status of input file\n'
c go through header
i=1
10 if (code(i:i).ne.' ') then
if (code(i:i).eq.'F') then
call sff_SkipFree(lu, ierr)
if (debug) print *,'DEBUG: skipped FREE block of file'
if (ierr.ne.0) stop 'ERROR: skipping FREE block\n'
elseif (code(i:i).eq.'S') then
read(lu, err=99, end=98, fmt='(1x)')
if (debug) print *,'DEBUG: skipped SOURCE line of file'
endif
i=i+1
goto 10
endif
return return
99 stop 'ERROR: skipping SOURCE line\n'
98 stop 'ERROR: unexpected end of file when skipping SOURCE line\n'
end end
c c
c---------------------------------------------------------------------- c----------------------------------------------------------------------
...@@ -1149,6 +1144,10 @@ c declare variables ...@@ -1149,6 +1144,10 @@ c declare variables
integer sample, ierr, i, ntrim, nstack integer sample, ierr, i, ntrim, nstack
character wid2line*132, code*20, line*80 character wid2line*132, code*20, line*80
real ampfac, stime, c3 real ampfac, stime, c3
logical last
integer maxfree, nfree, mfreelen
parameter(maxfree=50)
character*80 freelines(maxfree)
c go c go
call sff_TrimLen(infile,ntrim) call sff_TrimLen(infile,ntrim)
filename(trace)=infile(1:ntrim) filename(trace)=infile(1:ntrim)
...@@ -1160,14 +1159,20 @@ c go ...@@ -1160,14 +1159,20 @@ c go
c read trace c read trace
moretraces=.false. moretraces=.false.
nsamp=maxsamples-firstsample(trace) nsamp=maxsamples-firstsample(trace)
call sff_RData(lu, wid2line, nsamp, call sff_RTraceI(lu, sectime(trace), dt(trace),
& sectime(trace), dt(trace), & wid2line, nsamp,
& idata(firstsample(trace)), & sectime(trace), dt(trace),
& ampfac, code, ierr) & data(firstsample(trace)),
& idata(firstsample(trace)),
& nfree, freelines, maxfree, mfreelen,
& code, last,
& loccs(trace),locc1(trace),locc2(trace),
& c3,nstack,ierr)
if (ierr.ne.0) stop 'ERROR: reading trace'
nsamples(trace)=nsamp nsamples(trace)=nsamp
if ((nsamples(trace)+firstsample(trace)-1).gt.maxsamples) if ((nsamples(trace)+firstsample(trace)-1).gt.maxsamples)
& stop 'ERROR: too many samples\n' & stop 'ERROR: too many samples\n'
if (ierr.ne.0) stop 'ERROR: reading trace' moretraces=(.not.last)
c skip optional blocks but catch first line of FREE block c skip optional blocks but catch first line of FREE block
i=1 i=1
loccs(trace)='X' loccs(trace)='X'
......
Supports Markdown
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