chaco.f 5.52 KB
Newer Older
1
2
3
4
5
6
7
c this is <chaco.f>
c
c a little program to change the coordinate information in
c an sff datafile
c
c 30/04/1997   Thomas Forbriger   (IfG Stuttgart)
c 09/01/98   V1.1   set source type too
8
c 24/06/00   V1.2   don't use the error output channel for standard usage info
9
10
11
12
c
c======================================================================
      program chaco
      character*79 version
13
      parameter(version='CHACO   V1.2   change coordinates')
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
   
      integer maxsamp, maxfree
      parameter(maxsamp=100000, maxfree=400)

      integer luin, luout, luco
      parameter(luin=10, luout=11, luco=12)

      character*80 infile, outfile, cofile

      real c1,c2,c3,o1,o2,o3
      character*1 cs, os

      character*80 free(maxfree)
      integer nfree, nsamp, lenmax, nstack, chan
      real tanf, dt
      real fdata(maxsamp)
      integer idata(maxsamp)
      equivalence(fdata, idata)

      integer ierr
      character code*10, timestamp*20, date*20, time*20, type*40
      character stype*40
      character wid2line*132
      real sffversion
      logical last

      integer iargc
      character*80 arg

c----------------------------------------------------------------------
c output usage
45
46
47
      print *, version
      print *, 'Usage: chaco infile outfile cofile c1,c2,c3 cs sourcetype'
      print *, 'or:    chaco -help'
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
      if (iargc().eq.1) then
        call getarg(1, arg)
        if (arg(1:5).eq.'-help') then
          print *,'infile      sff input data file'
          print *,'outfile     sff output data file'
          print *,'cofile      file containing receiver coordinates'
          print *,'            (each line containes a vector triple in'
          print *,'            free format)'
          print *,'c1,c2,c3    vector coordinate triple for the source'
          print *,'            location'
          print *,'cs          either C or S indicating the type of'
          print *,'            coordinate system to use'
          print *,'sourcetype  something like ''sledge-hammer'' or ''SISSY'' '
          print *,' '
          print *,'As infile and outfile will be open at the same time'
          print *,'the must not have the same name!'
          print *,' '
          print *,'This binary is compiled for a maximum of'
          print *,'  FREE block lines: ',maxfree
          print *,'           samples: ',maxsamp
          stop
        endif
      endif
      if (iargc().ne.6) stop 'ERROR (chaco): wrong number of arguments'

c----------------------------------------------------------------------
c get arguments
      call getarg(1, infile)
      call getarg(2, outfile)
      call getarg(3, cofile)
      call getarg(4, arg)
      read(arg, *, err=99) c1,c2,c3
      call getarg(5, arg)
      call getarg(6, stype)
      cs=arg(1:1)

c----------------------------------------------------------------------
c open coordinate file
      print *,'opening inputfile ',cofile(1:index(cofile,' '))
      open(luco, file=cofile, status='old', err=93)

c----------------------------------------------------------------------
c process file header
c open input file
      print *,'opening input file ',infile(1:index(infile,' '))
      call sff_ROpenFS(luin, infile,
     &  sffversion, timestamp, code, nfree, free, lenmax, maxfree,
     &  type, os, o1, o2, o3,
     &  date, time, ierr)
      if (ierr.ne.0) stop 'ERROR (chaco): opening input file'
c check return values
      print *,'file was created ',timestamp(1:index(timestamp,' ')),
     &  ' by SFF version ',sffversion
      if (index(code,'S').eq.0)
     &  stop 'ERROR (chaco): file containes no SRCE line'
c add FREE line
      nfree=nfree+1
      write(free(nfree), 50, err=90) os, o1, o2, o3
   50 format("changed SRCE line from: (cs,c1,c2,c3) ",a1,3(1x,f12.3))
c open output file
      print *,'opening output file ',outfile(1:index(outfile,' '))
      call sff_WOpenFS(luout, outfile, free, nfree, stype,
     &  cs, c1, c2, c3, date, time, ierr)
      if (ierr.ne.0) stop 'ERROR (chaco): opening output file'

c----------------------------------------------------------------------
c process channels
      chan=1
    1 print *,'working on trace ',chan
      nsamp=maxsamp
c read input trace
      call sff_RTraceFI(luin, tanf, dt, wid2line, nsamp, fdata, idata,
     &  code, last, nfree, free, maxfree, lenmax,
     &  os, o1, o2, o3, nstack, ierr)
      if (ierr.ne.0) stop 'ERROR (chaco): reading input trace'
c check return values
      if (index(code,'I').eq.0)
     &  stop 'ERROR (chaco): trace containes no INFO line'
c add FREE line
      nfree=nfree+1
      write(free(nfree), 51, err=90) os, o1, o2, o3
   51 format('changed INFO line from: (cs,c1,c2,c3) ',a1,3(1x,f12.3))
c read coordinates
      read(luco, *, err=97, end=96) c1,c2,c3
c write output trace
      call sff_WTraceFI(luout, wid2line, nsamp, fdata, idata,
     &  last, nfree, free, 
     &  cs, c1, c2, c3, nstack, ierr)
      if (ierr.ne.0) stop 'ERROR (chaco): writing output trace'
      chan=chan+1
      if (.not.last) goto 1

c----------------------------------------------------------------------
c close files
      print *,'closing coordinate file'
      close(luco, err=98)
      stop

c----------------------------------------------------------------------
c catch error conditions
   99 stop 'ERROR (chaco): reading source location from arguments'
   98 stop 'ERROR (chaco): closing coordinate file'
   97 stop 'ERROR (chaco): reading coordinate file'
   96 stop 'ERROR (chaco): reading coordinate file - unexpected end of file'
   93 stop 'ERROR (chaco): opening coordinate file'
   90 stop 'ERROR (chaco): writing FREE block'
      end