Commit 58efa240 authored by thomas.forbriger's avatar thomas.forbriger Committed by thomas.forbriger
Browse files

new instructive code

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: 2194
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent b75056e5
# this is <Makefile>
# ----------------------------------------------------------------------------
# ($Id: Makefile,v 1.6 2002-11-02 21:19:30 forbrig Exp $)
# ($Id: Makefile,v 1.7 2006-12-19 15:42:21 tforb Exp $)
#
# 16/11/2001 by Thomas Forbriger (IMGF Frankfurt)
#
......@@ -56,4 +56,45 @@ bfotide gez: %: %.f
$(FC) -O3 -Wall -o$@ -ff90-intrinsics-hide -fno-automatic $<
newprog $@
#======================================================================
alldisp: dispfield.ps dispfield.bp10.fil.ps dispfield.bp100.fil.ps
dispfield: dispfield.o
$(CC) -o $@ $< -ltf -lsffu -lsff $(F2CLIB)
#----------------------------------------------------------------------
dispfield.%.sff: % dispfield.sff
stufi $< -o dispfield.sff
mv dispfield.sff.sfi $@
dispfield.sff: Makefile dispfield
dispfield $@ -t 1. -c 80.,180. -x 2.,40. -f 5.,150. -n 12 -N 20 \
-e 1. -T 0.4
REFRACTOPT=-Sx -0.,30. -Sa 0.8 \
-Eg -St 0.,0.5 -Tx 'Zeit (s)' -Ty 'Offset (m)' \
-Tm F -Tl F -Ts 1.1 -Lw 3
REFRACTTRACE=t:1-14
dispfield.ps: dispfield.sff Makefile
refract $(REFRACTOPT) -Tt 'Dispergierter Wellenzug' \
-d $@/vps $< $(REFRACTTRACE)
dispfield.bp10.fil.ps: dispfield.bp10.fil.sff Makefile
refract $(REFRACTOPT) -Tt 'Dispergierter Wellenzug (Bandpass bei 10Hz)' \
-d $@/vps $< $(REFRACTTRACE)
dispfield.bp100.fil.ps: dispfield.bp100.fil.sff Makefile
refract $(REFRACTOPT) -Tt 'Dispergierter Wellenzug (Bandpass bei 100Hz)' \
-d $@/vps $< $(REFRACTTRACE)
dispfield.bp100.red.ps: dispfield.bp100.fil.sff Makefile
refract $(REFRACTOPT) -Tt 'Dispergierter Wellenzug (f\dBandpass\u=100Hz, v\dred\u=114m/s)' \
-Sr .114 -St -0.1,0.2 -d $@/vps $< $(REFRACTTRACE)
%.psp: %.ps
ghostview $<
#
# ----- END OF Makefile -----
c this is <dispfield.f>
c------------------------------------------------------------------------------
c ($Id: dispfield.f,v 1.1 2006-12-19 15:42:21 tforb Exp $)
c
c 09/02/2001 by Thomas Forbriger (IMGF Frankfurt)
c
c dispersed wavefield
c
c REVISIONS and CHANGES
c 09/02/2001 V1.0 Thomas Forbriger
c
c==============================================================================
c
program dispfield
c
character*(*) version
parameter(version='DISPFIELD V1.0 create field of harmonic plane waves')
c
logical last
character*80 filename
integer nmax,i,ntrace,n,j,lu,nexp
parameter(nmax=10000,lu=10)
real x(nmax)
complex cx(nmax),ime
parameter(ime=(0.,1.))
real xmin,xmax,cmin,cmax,tmax,fmin,fmax,expo,tap,pi2,dt,r,f
real hin,df,c,a,fny,m,c0,fwil,fwir,tf_costap
integer ifmin, ifmax, ifwil, ifwir
parameter(pi2=2.* 3.1415926535, hin=1.)
c commandline
integer maxopt, lastarg, iargc
character*80 argument
parameter(maxopt=10)
character*2 optid(maxopt)
character*40 optarg(maxopt)
logical optset(maxopt), opthasarg(maxopt)
c debugging
logical debug, verbose
c here are the keys to our commandline options
data optid/2h-d, 2h-v, 2h-x, 2h-c, 2h-t, 2h-n, 2h-f, 2h-N, 2h-T, 2h-e/
data opthasarg/2*.FALSE.,8*.TRUE./
data optarg/2*1h-,'2.,50.','10.,80.','1.','1024','5.,80.', '25', '0.2',
& '0.2'/
c
c------------------------------------------------------------------------------
c basic information
c
c
argument=' '
if (iargc().eq.1) call getarg(1, argument)
if ((argument(1:5).eq.'-help').or.(iargc().lt.1)) then
print *,version
print *,'Usage: dispfield arguments'
print *,' or: dispfield -help'
if (argument(1:5).ne.'-help') stop 'ERROR: wrong number of arguments'
print *,' '
print *,'create dispersed wavefield'
print *,' '
stop
endif
c
c------------------------------------------------------------------------------
c read command line arguments
c
call getarg(1, filename)
call tf_cmdline(2, lastarg, maxopt, optid,
& optarg, optset, opthasarg)
debug=optset(1)
verbose=optset(2)
read(optarg(3), *) xmin, xmax
read(optarg(4), *) cmin,cmax
read(optarg(5), *) tmax
read(optarg(6), *) nexp
read(optarg(7), *) fmin,fmax
read(optarg(8), *) ntrace
read(optarg(9), *) tap
read(optarg(10), *) expo
c
c------------------------------------------------------------------------------
c go
n=2**nexp
if (n.gt.nmax) stop 'ERROR: too many samples'
dt=tmax/float(n)
df=1./tmax
fny=0.5/dt
c print *,'n,dt,df,fny:',n,dt,df,fny
if (fmax.gt.fny) stop 'ERROR: frequency too large'
m=(cmax-cmin)/(fmin**expo-fmax**expo)
c0=cmax-m*fmin**expo
print *,'c0,m,expo: ',c0,m,expo
fwil=fmin+tap*(fmax-fmin)
fwir=fmax-tap*(fmax-fmin)
ifmin=fmin/df+1
ifmax=fmax/df+1
ifwil=fwil/df+1
ifwir=fwir/df+1
call sff_New(lu, filename, i)
call sffu_simpleopen(lu, filename)
do i=1,ntrace
r=(i-1)*(xmax-xmin)/float(ntrace-1)+xmin
last=.false.
if (i.eq.ntrace) last=.true.
c if (i.eq.2) then
c print *,'r,ime,pi2,hin:',r,ime,pi2,hin
c endif
do j=1,n/2
f=(j-1)*df
c=c0+m*f**expo
cx(j)=exp(-ime*pi2*f*r/c)*a
cx(n-j+1)=conjg(cx(j))
a=tf_costap(j,ifmin,ifwil,ifwir,ifmax)
c if (i.eq.2) then
c print *,'f,c,a:',f,c,a,cx(j)
c endif
enddo
call tf_fork(n,cx,hin)
do j=1,n
x(j)=real(cx(j))
enddo
call sffu_simplewrite(lu, last, x, n, dt, r)
enddo
c
stop
end
c
c ----- END OF dispfield.f -----
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