Commit 44a540cb authored by thomas.forbriger's avatar thomas.forbriger Committed by thomas.forbriger
Browse files

correction

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: 2942
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent ac3f246c
c this is <greda.f>
c------------------------------------------------------------------------------
c $Id: greda.f,v 1.21 2009-11-27 09:49:37 tforb Exp $
c $Id: greda.f,v 1.22 2009-11-27 15:57:03 tforb Exp $
c
c 24/06/97 by Thomas Forbriger (IfG Stuttgart)
c
......@@ -97,6 +97,7 @@ c 28/03/06 V3.15 - apply special (offset dependent taper) after
c rescaling waveforms
c - corrected subroutine specialtap
c 27/11/09 V3.16 - some corrections to satify gfortran
c V3.17 - pwo_init takes an argument!
c
c==============================================================================
c
......@@ -105,9 +106,9 @@ c
c first we declare some general variables
c
character*79 version,CVSID
parameter(version='GREDA V3.16 Greens function from data')
parameter(version='GREDA V3.17 Greens function from data')
parameter(CVSID=
& '$Id: greda.f,v 1.21 2009-11-27 09:49:37 tforb Exp $')
& '$Id: greda.f,v 1.22 2009-11-27 15:57:03 tforb Exp $')
c
c calculations common block
include 'greda_dim.inc'
......@@ -385,7 +386,7 @@ c
print *,'rho should be chosen somewhere around delta_r_min*omega,'
print *,'where delta_r_min is the minimal offset difference.'
print *,' '
print *,'$Id: greda.f,v 1.21 2009-11-27 09:49:37 tforb Exp $'
print *,'$Id: greda.f,v 1.22 2009-11-27 15:57:03 tforb Exp $'
call pwo_cvsid
print *,' '
print *,'compiled array dimensions are:'
......@@ -400,67 +401,72 @@ c
stop
endif
c
c----------------------------------------------------------------------
c initialize common block for phasor walkout
call pwo_init
c
c----------------------------------------------------------------------
c
c configure from command line
c
c print *,'DEBUG: call iargc'
if (iargc().lt.2) stop 'ERROR: missing parameters'
c print *,'DEBUG: call tf_cmdline'
call tf_cmdline(3, lastarg,
& maxopt, optid, optarg, optset, opthasarg)
c print *,'DEBUG: returned from tf_cmdline'
call getarg(1, filename)
call getarg(2, greensfile)
debug=optset(1)
read(optarg(2), '(f10.3)', err=99) tapfrac
if (debug) print *,'DEBUG: in options - place 1'
read(optarg(2), *, err=99) tapfrac
if (tapfrac.gt.50.) stop 'ERROR: silly taper'
if (tapfrac.lt.0.) stop 'ERROR: negative taper'
read(optarg(3), '(f10.3)', err=99) smax
read(optarg(3), *, err=99) smax
smax=smax*0.001
read(optarg(4), '(i10)', err=99) nslo
if (nslo.lt.1) stop 'ERROR: need positive number of slownesses'
if (nslo.gt.maxslo) stop 'ERROR: too many slownesses'
read(optarg(5), '(f10.3)', err=99) fmax
read(optarg(5), *, err=99) fmax
if (fmax.lt.0.) stop 'ERROR: negative maximum frequency'
overwrite=optset(6)
if (debug) print *,'DEBUG: in options - place 2'
hankel1=optset(7)
hankel2=optset(8)
verbose=optset(9)
offtaper=optset(10)
if (offtaper) then
read(optarg(10), '(f10.3)', err=99) offtapfrac
read(optarg(10), *, err=99) offtapfrac
if (offtapfrac.gt.50.) stop 'ERROR: silly taper'
if (offtapfrac.lt.0.) stop 'ERROR: negative taper'
endif
if (debug) print *,'DEBUG: in options - place 3'
uzerospecial=optset(11)
matrixmethod=optset(12)
lininv=optset(13)
read (optarg(14), '(2f10.3)') sigma,expon
read (optarg(14), *) sigma,expon
edgeset=optset(15)
if (edgeset) then
read(optarg(15), '(f10.3)', err=99) edgefrac
read(optarg(15), *, err=99) edgefrac
if (edgefrac.gt.1.) stop 'ERROR: end of taper behind last sample'
if (edgefrac.lt.(0.02*tapfrac))
& stop 'ERROR: edge does not leave enough space for taper'
endif
if (debug) print *,'DEBUG: in options - place 4'
linkinv=optset(16)
disgram=optset(17)
softcosine=optset(18)
gausstaper=optset(19)
gausstime=optset(20)
parkermethod=optset(21)
read (optarg(22), '(f10.3)') minoff
read (optarg(22), *) minoff
if ((.not.optset(14)).and.(optset(23)))
& read (optarg(23), '(2f10.3)') sigma,expon
& read (optarg(23), *) sigma,expon
stackso=optset(24)
if (stackso) read (optarg(24), '(f10.3)') stackdelta
if (stackso) read (optarg(24), *) stackdelta
planewave=optset(25)
rescale=optset(26)
if (debug) print *,'DEBUG: in options - place 5'
specrescale=optset(27)
if (rescale) then
read(optarg(26), '(f10.3)') rescaleexpo
read(optarg(26), *) rescaleexpo
if (specrescale) rescale=.false.
else
specrescale=.false.
......@@ -470,6 +476,7 @@ c
backtranscale=optset(29)
applywltaper=optset(30)
read(optarg(30), *) wltaplen, wltapfrac
if (debug) print *,'DEBUG: in options - place 6'
specialtaper=optset(31)
if (specialtaper) read(optarg(31), *) (tapoffsets(i), i=1,4)
writeFourier=optset(32)
......@@ -480,9 +487,17 @@ c
pwffilename=optarg(34)
pwoautofile=optset(35)
pwafilename=optarg(35)
if (debug) print *,'DEBUG: read options'
c
if ((.not.(planewave)).and.(smax.lt.0.))
& stop 'ERROR: negative maximum slowness'
c----------------------------------------------------------------------
c initialize common block for phasor walkout
c print *,'DEBUG: call pwo_init'
call pwo_init(verbose)
c print *,'DEBUG: returned from pwo_init'
c----------------------------------------------------------------------
c report
print *,' '
if (hankel1) then
......@@ -499,6 +514,7 @@ c report
print *,' '
c
c initialize wavelength taper factors
if (debug) print *,'DEBUG: call initwltaper(wltaplen,wltapfrac)'
call initwltaper(wltaplen,wltapfrac)
c
c----------------------------------------------------------------------
......@@ -514,8 +530,10 @@ c
c go for the real calculations
c
c read seismic data
if (debug) print *,'DEBUG: call readdata'
call readdata(filename, fdata, idata, spectra, r, maxr,
& maxtr, maxsamp, ntr, nsamp, dt, tfirst)
if (debug) print *,'DEBUG: returned from readdata'
c
if ((.not.optset(4)).or.(matrixmethod)) nslo=ntr
if (nslo.gt.maxslo) stop 'ERROR: too many slownesses - check code'
......
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