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

gfortran correction for taper reading

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: 2969
SVN UUID:     67feda4a-a26e-11df-9d6e-31afc202ad0c
parent a5e2e635
c this is <testlibtf.f>
c ----------------------------------------------------------------------------
c ($Id: testlibtf.f,v 1.5 2009-11-27 10:37:21 tforb Exp $)
c ($Id: testlibtf.f,v 1.6 2010-02-04 11:21:58 tforb Exp $)
c
c Copyright (c) 2007 by Thomas Forbriger (BFO Schiltach)
c
......@@ -26,6 +26,7 @@ c REVISIONS and CHANGES
c 09/05/2007 V1.0 Thomas Forbriger
c 17/12/2007 V1.1 use keyword file in open statement
c 27/11/2009 V1.2 test magic numbers
c 04/02/2010 V1.3 test taper reading
c
c ============================================================================
c
......@@ -33,10 +34,10 @@ c
c
character*(*) version
parameter(version=
&'TESTLIBTF V1.2 program to test libtf functions')
&'TESTLIBTF V1.3 program to test libtf functions')
character*(*) TESTLIBTF_CVS_ID
parameter(TESTLIBTF_CVS_ID=
&'$Id: testlibtf.f,v 1.5 2009-11-27 10:37:21 tforb Exp $')
&'$Id: testlibtf.f,v 1.6 2010-02-04 11:21:58 tforb Exp $')
c
integer m,i,n
parameter(m=10000)
......@@ -45,18 +46,19 @@ c
c commandline
integer maxopt, lastarg, iargc
character*80 argument
parameter(maxopt=6)
parameter(maxopt=7)
character*7 optid(maxopt)
character*40 optarg(maxopt)
character*80 optarg(maxopt)
logical optset(maxopt), opthasarg(maxopt)
c
logical testrng, fileoutput, testmagic
logical testrng, fileoutput, testmagic, testrtaper
character*80 taperfile
c debugging
logical debug, verbose
c here are the keys to our commandline options
data optid/2h-d, 2h-v, 4h-rng, 2h-f, 2h-n, '-magic'/
data opthasarg/4*.FALSE.,.TRUE.,.FALSE./
data optarg/4*1h-,3h150,'-'/
data optid/2h-d, 2h-v, 4h-rng, 2h-f, 2h-n, '-magic', '-rtaper'/
data opthasarg/4*.FALSE.,.TRUE.,.FALSE.,.TRUE./
data optarg/4*1h-,3h150,2*'-'/
c
c------------------------------------------------------------------------------
c basic information
......@@ -67,7 +69,7 @@ c
if ((argument(1:5).eq.'-help').or.(iargc().lt.1)) then
print *,version
print *,'Usage: testlibtf [-v] [-f] [-n n]'
print *,' [-rng] [-magic]'
print *,' [-rng] [-magic] [-rtaper f]'
print *,' or: testlibtf -help'
if (argument(1:5).ne.'-help')
& stop 'ERROR: wrong number of arguments'
......@@ -83,6 +85,7 @@ c
print *,'select tests:'
print *,'-rng test gsl random number generator'
print *,'-magic test magic numbers'
print *,'-rtaper f test reading a quad taper from file ''f'' '
stop
endif
c
......@@ -97,6 +100,8 @@ c
fileoutput=optset(4)
read(optarg(5), *, err=96) n
testmagic=optset(6)
taperfile=optarg(7)
testrtaper=optset(7)
c
c------------------------------------------------------------------------------
c go
......@@ -124,6 +129,13 @@ c----------------------------------------------------------------------
call tf_magic(cmagic, n)
print *,'magic number for "',cmagic,'" is ',n
endif
c----------------------------------------------------------------------
if (testrtaper) then
print *,'read quad-taper from file'
print *,taperfile
call rtapertest(taperfile)
endif
c----------------------------------------------------------------------
c
stop
99 stop 'ERROR: opening file'
......@@ -132,5 +144,31 @@ c
96 stop 'ERROR: reading command line'
end
c
c======================================================================
c
subroutine rtapertest(filename)
c
character*(*) filename
c
character text*80
integer maxpicks
parameter(maxpicks=100)
real t(maxpicks,4)
real x(maxpicks,4)
integer npicks(maxpicks)
integer i,j
c
call tf_ttapread(filename, t, x, npicks, maxpicks, text)
print *,'comment in file:'
print *,text
do i=1,4
print *,'taper curve #',i
do j=1,npicks(i)
print *,j,': ',t(j,i),'s ',x(j,i),'m'
enddo
enddo
c
return
end
c
c ----- END OF testlibtf.f -----
......@@ -23,14 +23,17 @@ c ----
c
c REVISIONS and CHANGES
c 08/07/98 V1.0 Thomas Forbriger
c 04/02/10 V1.1 had to fix reading
c gfortran apparently interprets formats in a different
c way
c
c==============================================================================
cS
c
subroutine tf_ttapread(filename, t, x, npicks, maxpicks, text)
c
character filename*(*)
character text*(*)
character*(*) filename
character*(*) text
real t(maxpicks,4)
real x(maxpicks,4)
integer npicks(maxpicks)
......@@ -40,11 +43,19 @@ cE
integer lu, i, j
parameter(lu=9)
c
c print *,'open file:'
c print *,filename
open(lu, file=filename, status='old', err=99)
c
read(lu, 50, err=98, end=97) text
c print *,'comment:'
c print *,text
do i=1,4
read(lu, *, err=98, end=97)
c print *,'skipped 1'
read(lu, 51, err=98, end=97) npicks(i)
read(lu, *, err=98, end=97)
c print *,i,npicks(i)
if (npicks(i).gt.0) read(lu, 52, err=98, end=97)
& (x(j,i), t(j,i), j=1,npicks(i))
enddo
......@@ -52,8 +63,8 @@ c
close(lu, err=96)
c
return
50 format('offset dependent time domain taper'/a80)
51 format(/'taper set ',2x,' with ',i3,' picks'/' offset [m] time [s]')
50 format(/a80)
51 format(18x,i3)
52 format(2g15.6)
99 stop 'ERROR (tf_ttapread): opening file'
98 stop 'ERROR (tf_ttapread): reading file'
......
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