Commit 1bbc448a authored by thomas.forbriger's avatar thomas.forbriger Committed by thomas.forbriger
Browse files

compiles with flgevas suite support

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/trunk
SVN Revision: 1174
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent 45f4e5a0
c this is <fidase.f>
c------------------------------------------------------------------------------
c $Id: fidase.f,v 1.2 2001-10-23 20:59:42 forbrig Exp $
c $Id: fidase.f,v 1.3 2002-12-06 20:50:53 forbrig Exp $
c
c 09/07/98 by Thomas Forbriger (IfG Stuttgart)
c
......@@ -12,6 +12,7 @@ c 12/08/98 V1.1 improved help text
c 25/11/98 V1.2 now does resampling
c 27/02/99 V1.3 scale energies offset dependent
c 23/10/01 V1.4 destack option
c 06/12/02 V1.5 support flgevask inversion inv1d
c
c==============================================================================
c
......@@ -19,32 +20,36 @@ c
c
character*79 version
parameter(version=
& 'FIDASE V1.4 FIt DAtaSets - make datasets homogeneous')
& 'FIDASE V1.5 FIt DAtaSets - make datasets homogeneous')
c
c common blocks
include 'fidase_para.inc'
include 'fidase_strings.inc'
include 'fidase_dim.inc'
include 'fidase_data.inc'
c options
logical overwrite, opttaper, optenfit, optdestack
logical optrenamestat, optwritesingle
c
real enfminoff, enfmindelta, enfexpo
logical optresamp
c
real newdt
integer newsamppow
integer newsamppow, i, itrace
character*5 newstationid
c filenames
character*80 outfile, tapfile
c commandline
integer maxopt, lastarg, iargc
character*80 argument
parameter(maxopt=9)
parameter(maxopt=11)
character*2 optid(maxopt)
character*40 optarg(maxopt)
logical optset(maxopt), opthasarg(maxopt)
c here are the keys to our commandline options
data optid/2h-D,2h-v,2h-o,2h-t,2h-e,2h-d,2h-r,2h-E,2h-s/
data opthasarg/3*.FALSE.,.TRUE.,4*.TRUE.,.FALSE./
data optarg/3*1h-,1h-,1h-,3hx11,1h-,2h1.,1h-/
data optid/2h-D,2h-v,2h-o,2h-t,2h-e,2h-d,2h-r,2h-E,2h-s,2h-R,2h-S/
data opthasarg/3*.FALSE.,.TRUE.,4*.TRUE.,3*.FALSE./
data optarg/3*1h-,1h-,1h-,3hx11,1h-,2h1.,3*1h-/
c
c------------------------------------------------------------------------------
c basic information
......@@ -56,6 +61,7 @@ c
print *,version
print *,'Usage: fidase [-D] [-v] [-o] [-t file] [-e min,mind]'
print *,' [-d device] [-r n,dt] [-E exp] [-s]'
print *,' [-R] [-S]'
print *,' file1 file2 ... target'
print *,' or: fidase -help'
if (iargc().lt.1) stop 'ERROR: missing arguments'
......@@ -84,6 +90,9 @@ c
print *,' samples values will be divided by the'
print *,' stack counter upon read and the stack'
print *,' counter will be reset to 1'
print *,'-R rename all station id to make them unique'
print *,' within the output file'
print *,'-S write each trace to a single file'
print *,' '
print *,'file? input datasets'
print *,'target filename for homogeneus output dataset'
......@@ -93,6 +102,8 @@ c
print *,'the last one as it will be then used as the reference.'
print *,'This prevents the algorithm from make second derivatives'
print *,'small just be setting this trace to zero.'
print *,' '
print *,'$Id: fidase.f,v 1.3 2002-12-06 20:50:53 forbrig Exp $'
stop
endif
c
......@@ -116,6 +127,8 @@ c
if (optresamp) read (optarg(7), *, err=99) newsamppow,newdt
read(optarg(8), *, err=99) enfexpo
optdestack=optset(9)
optrenamestat=optset(10)
optwritesingle=optset(11)
c
if ((iargc()-lastarg).lt.2) stop 'ERROR: too few filenames'
c
......@@ -135,11 +148,26 @@ c eval tapers
call evaltaper
endif
c
c scale amplitudes
if (optenfit) call enfit(enfminoff, enfmindelta, enfexpo)
c
call writedata(outfile, overwrite)
c rename stations
if (optrenamestat) then
if (verbose) print *,'rename stations:'
i=firstinchain
do itrace=1,ntraces
write(newstationid, 50) itrace
if (verbose) print *,' ',station(i),' --> ',newstationid
station(i)=newstationid
i=chain(i)
enddo
endif
c
c write result
call writedata(outfile, overwrite, optwritesingle)
c
stop
50 format('B',i3.3,' ')
99 stop 'ERROR: reading min,mind from arguments'
end
c
......
c this is <fidase_writedata.f>
c------------------------------------------------------------------------------
c $Id: fidase_writedata.f,v 1.2 2001-10-23 20:59:42 forbrig Exp $
c $Id: fidase_writedata.f,v 1.3 2002-12-06 20:50:53 forbrig Exp $
c
c 09/07/98 by Thomas Forbriger (IfG Stuttgart)
c
......@@ -9,10 +9,11 @@ c
c REVISIONS and CHANGES
c 09/07/98 V1.0 Thomas Forbriger
c 23/10/01 V1.1 write stack counter
c 06/12/02 V1.2 support inv1d from flgevask bundle (write single)
c
c==============================================================================
c
subroutine writedata(outfile, overwrite)
subroutine writedata(outfile, overwrite, optwritesingle)
c
c write full dataset to filename
c overwrite all dataset if true
......@@ -23,15 +24,16 @@ c
include 'fidase_strings.inc'
c
character outfile*(*)
logical overwrite
logical overwrite, optwritesingle
c
integer lu, ierr, i
integer lu, ierr, i, j
parameter(lu=11)
c
integer itrace, ifile
c
c source
character stype*20, sdate*6, stime*10
character*90 singletracefile
c data
integer idata(maxsamples)
equivalence(data, idata)
......@@ -46,7 +48,8 @@ c WID2 info
integer wid2date(7), refdate(7), startdate(7)
c
if (overwrite) then
if (verbose) print *,'removing file ',outfile(1:index(outfile, ' '))
if (verbose) print *,'removing file ',
& outfile(1:index(outfile, ' '))
call sff_New(lu, outfile, ierr)
if (ierr.ne.0) then
print *,'WARNING (writedata): could not remove old file'
......@@ -63,17 +66,59 @@ c create file FREE block
free(2)=string_version
nfree=2
c
if (verbose) print *,'writing to file ',outfile(1:index(outfile, ' '))
call sff_WOpenFS(lu, outfile, free, nfree, stype, 'C',
& 0., 0., 0., sdate, stime, ierr)
if (ierr.ne.0) stop 'ERROR (writedata): could not open file'
c open if in write-at-once mode
if (.not.(optwritesingle)) then
c
if (overwrite) then
if (verbose) print *,'removing file ',
& outfile(1:index(outfile, ' '))
call sff_New(lu, outfile, ierr)
if (ierr.ne.0) then
print *,'WARNING (writedata): could not remove old file'
return
endif
endif
c
if (verbose) print *,'writing to file ',
& outfile(1:index(outfile, ' '))
call sff_WOpenFS(lu, outfile, free, nfree, stype, 'C',
& 0., 0., 0., sdate, stime, ierr)
if (ierr.ne.0) stop 'ERROR (writedata): could not open file'
endif
c
i=firstinchain
do itrace=1,ntraces
if (verbose) print 50,itrace,ntraces,i,roffset(i)
ifile=fileindex(i)
last=.false.
if (itrace.eq.ntraces) last=.true.
c
c open if in write-single-traces mode
if (optwritesingle) then
c
singletracefile=outfile
j=index(singletracefile,' ')
singletracefile(j:j)='.'
singletracefile(j+1:j+5)=station(i)
if (overwrite) then
if (verbose) print *,'removing file ',
& singletracefile(1:index(singletracefile, ' '))
call sff_New(lu, singletracefile, ierr)
if (ierr.ne.0) then
print *,'WARNING (writedata): could not remove old file'
return
endif
endif
c
if (verbose) print *,'writing to file ',
& singletracefile(1:index(singletracefile, ' '))
call sff_WOpenFS(lu, singletracefile, free, nfree, stype, 'C',
& 0., 0., 0., sdate, stime, ierr)
if (ierr.ne.0) stop 'ERROR (writedata): could not open file'
c
last=.true.
endif
c
ifile=fileindex(i)
c prepare WID2 line
call time_clear(startdate)
call time_clear(refdate)
......
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