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:
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
c V1.27 18/01/08 do not use write statement for annotations
c just assign to character variable line
c V1.28 04/12/09 use correct DIN notation for units
c V1.29 02/01/11 start implementing libfapidxx
program stuplo
......@@ -89,7 +90,7 @@ c
c version
character*77 version, creator
& '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)')
c parameter definitions
integer maxsamples, maxselect, lu, maxtraces, maxchain, maxstyle
......@@ -109,7 +110,7 @@ c counters
c variables
logical debug, verbose, goahead
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 and this big array will hold real and integer data together
c the way we do this both real and integer type variables
......@@ -121,6 +122,7 @@ c arras to hold information on data
integer nsamples(maxtraces), firstsample(maxtraces)
integer traceinfile(maxtraces)
character*80 filename(maxtraces), firstfree(maxtraces)
character*80 informat
character*10 date(maxtraces)
character*12 time(maxtraces)
character*5 station(maxtraces)
......@@ -177,27 +179,31 @@ c variables related to pgplot
real timeax(maxsamples)
c commandline
integer maxopt, lastarg, iargc
character*3 optid(maxopt)
character*200 optarg(maxopt)
logical optset(maxopt), opthasarg(maxopt)
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,
& 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.,
& 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-,
& 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 give basic information and help
line=' '
if (iargc().eq.1) call getarg(1, line)
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
elseif ((line(1:5).eq.'-help').or.(iargc().lt.1)) then
print 80,version
print *,creator
print 80,'Usage: stuplo [-d dev] [-g] [-a] [-i] [-t] [-k] [-N]'
......@@ -207,14 +213,16 @@ c give help information
print 80,' [-l std,lab,cur] [-h std,xlab,ylab,cap]'
print 80,' [-X label] [-T title] [-S sec] [-E]'
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,'or: stuplo -help'
print 80,'or: stuplo -xhelp'
if (iargc().lt.1) stop 'ERROR: missing parameters\n'
print *,' '
print *,'STUPLO plots seismic time series that are stored'
print *,'in SFF format (Stuttgart File Format).'
print *,' '
print *,'-ty f select input file format (see below)'
print *,'-d dev This option selects the pgplot output'
print *,' device. Information on available ouput'
print *,' devices is given below.'
......@@ -373,6 +381,7 @@ c give help information
print *,' maximum number of chains to build:',maxchain
print *,' maximum number of different plot styles:',maxstyle
print *,' '
call sff_help_formats
......@@ -441,6 +450,7 @@ c first read the commandline
read(optarg(35), *, end=96, err=97) majorxticks, nminorxticks
read(optarg(36), *, end=96, err=97) nmajorxticks, minorxticks
c device='/krm3'
c initialize
......@@ -471,9 +481,10 @@ c is there a new chain to start
if ( stop 'ERROR: opened too many chains'
goto 4
call sff_TrimLen(infile,ntrim)
ntrim=index(infile,' ')-1
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 ( stop 'ERROR: selecting input file format'
call sffopen(lu, filep, useselect, selection, maxselect, debug)
c start trace loop
......@@ -1064,7 +1075,7 @@ c declare parameters
c declare variables
integer ierr, i
real sffversion
character timestamp*13, code*20, line*80
character timestamp*13, code*20, line*80, filename*80
c go
c evaluate trace selections
call getarg(filep+1, line)
......@@ -1088,27 +1099,11 @@ c evaluate trace selections
call getarg(filep, filename)
c read file header and ignore optional blocks
call sff_RStatus(lu,sffversion,timestamp,code,ierr)
if (debug) print *,'DEBUG: read status'
if ( stop 'ERROR: reading status of input file\n'
c go through header
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 ( 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'
goto 10
call sff_ROpen(lu, filename, sffversion,timestamp,code,ierr)
if ( stop 'ERROR: opening file'
99 stop 'ERROR: skipping SOURCE line\n'
98 stop 'ERROR: unexpected end of file when skipping SOURCE line\n'
......@@ -1149,6 +1144,10 @@ c declare variables
integer sample, ierr, i, ntrim, nstack
character wid2line*132, code*20, line*80
real ampfac, stime, c3
logical last
integer maxfree, nfree, mfreelen
character*80 freelines(maxfree)
c go
call sff_TrimLen(infile,ntrim)
......@@ -1160,14 +1159,20 @@ c go
c read trace
call sff_RData(lu, wid2line, nsamp,
& sectime(trace), dt(trace),
& idata(firstsample(trace)),
& ampfac, code, ierr)
call sff_RTraceI(lu, sectime(trace), dt(trace),
& wid2line, nsamp,
& sectime(trace), dt(trace),
& data(firstsample(trace)),
& idata(firstsample(trace)),
& nfree, freelines, maxfree, mfreelen,
& code, last,
& loccs(trace),locc1(trace),locc2(trace),
& c3,nstack,ierr)
if ( stop 'ERROR: reading trace'
if ((nsamples(trace)+firstsample(trace)-1).gt.maxsamples)
& stop 'ERROR: too many samples\n'
if ( stop 'ERROR: reading trace'
c skip optional blocks but catch first line of FREE block
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