1
2
3
4
5
6
7
8
9
10
11
12
13
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
45
46
47
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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
|
program ttimes
save
parameter (max=60)
logical log,prnt(3)
character*8 phcd(max),phlst(10)
character*80 modnam
dimension tt(max),dtdd(max),dtdh(max),dddp(max),mn(max),ts(max)
dimension usrc(2)
character*2 opt(10)
character*80 opt_set(10),file
character*6 stn
integer nopt, i, inputlu, outputlu
logical check_opt
character*80 get_opt
data opt/'+i','+o','+m','?','+p','-l',4*' '/,nopt/6/
data opt_set/10*' '/
data in/1/,phlst(1)/'ALL'/,prnt(3)/.false./
data modnam/'/signals/public/trt_tab/iasp91'/
c
call fparm(opt,nopt,opt_set,file,1,i)
if(check_opt(opt,opt_set,nopt,'?')) then
write(6,*) 'This routine for calculating travel times for'
write(6,*) 'specific distances uses a set of precalculated'
write(6,*) 'tau-p tables for the iasp91 model stored as'
write(6,*) ' iasp91.hed, iasp91.tbl'
write(6,*)
write(6,*) 'The source depth has to be specified and also'
write(6,*) 'the phase codes or keywords for the required branches'
write(6,*) 'ALL will give all available branches'
write(6,*) 'P gives P-up,P,Pdiff,PKP, and PKiKP'
write(6,*) 'P+ gives P-up,P,Pdiff,PKP,PKiKP,PcP,pP,pPdiff,pPKP,'
write(6,*) ' pPKiKP,sP,sPdiff,sPKP, and sPKiKP'
write(6,*) 'S gives S-up,S,Sdiff, and SKS'
write(6,*) 'S+ gives S-up,S,Sdiff,SKS,sS,sSdiff,sSKS,pS,pSdiff,'
write(6,*) ' and pSKS '
write(6,*) 'BASIC gives P+ and S+ as well as '
write(6,*) ' ScP, SKP, PKKP, SKKP, PP, and PKPPKP '
write(6,*)
write(6,*) 'or give a generic phase name'
write(6,*)
write(6,*) 'You will have to enter a distance,'
write(6,*) 'if this is negative a new depth is calculated'
write(6,*) 'TO EXIT: give negative depth'
write(6,*)
write(6,*) 'RUNSTRING PARAMETERS:'
write(6,*) '====================='
write(6,*) '+i fname parameter input file'
write(6,*) ' format:'
write(6,*) ' xxxxxx (depth [km] )'
write(6,*) ' stname yyyy (name delta[deg])'
write(6,*) ' repeat previous line'
write(6,*) '+o fname parameter output file'
write(6,*) '+m model special model file'
write(6,*) ' default: /signals/public/trt_tab/iasp91'
write(6,*) '+p phase phase is one of the above types'
write(6,*) '-l list possible phases'
stop
endif
if(check_opt(opt,opt_set,nopt,'+i')) then
inputlu=55
file= get_opt(opt,opt_set,nopt,'+i')
call assign(inputlu,1,file)
else
inputlu= 5
endif
if(check_opt(opt,opt_set,nopt,'+o')) then
outputlu=66
file= get_opt(opt,opt_set,nopt,'+o')
call assign(outputlu,2,file)
else
outputlu= 6
endif
if(check_opt(opt,opt_set,nopt,'+m')) then
modnam= get_opt(opt,opt_set,nopt,'+m')
endif
if(check_opt(opt,opt_set,nopt,'-l')) then
prnt(3)= .true.
endif
if(check_opt(opt,opt_set,nopt,'+p')) then
phlst(1)= get_opt(opt,opt_set,nopt,'+p')
endif
prnt(1) = .false.
prnt(2) = .false.
call assign(10,2,'ttim1.lis')
call tabin(in,modnam)
call brnset(1,phlst,prnt,outputlu)
c choose source depth
3 if(inputlu.eq.5) call query('Source depth (km):',log)
read(inputlu,*)zs
if(zs.lt.0.) go to 13
call depset(zs,usrc)
c loop on delta
1 if(inputlu.eq.5) then
write(*,*)
call query('Enter delta:',log)
read(inputlu,*)delta
if(delta.lt.0.) go to 3
else
read(inputlu,*,end=13,err=13) stn, delta
write(outputlu,'(" station: ",a)') stn
endif
write(outputlu,'(" delta:",f7.2," depth:",f7.2)') delta,zs
write(outputlu,'(2a)')
%' # code time(s) (min s) dT/dD',
%' dT/dh d2T/dD2'
call trtm(delta,max,n,tt,dtdd,dtdh,dddp,phcd)
if(n.le.0) go to 2
do 4 i=1,n
mn(i)=int(tt(i)/60.)
ts(i)=amod(tt(i),60.)
4 continue
c
write(outputlu,100) (i,phcd(i),tt(i),mn(i),ts(i),
1 dtdd(i),dtdh(i),dddp(i),i=1,n)
100 format(i5,2x,a,0pf9.2,i4,f7.2,f11.4,1p2e11.2)
go to 1
2 write(outputlu,101)delta
101 format(/1x,'No arrivals for delta =',f7.2)
go to 1
c end delta loop
13 call retrns(in)
call retrns(10)
if(outputlu.ne.6) call retrns(outputlu)
call exit(0)
end
subroutine asnag1(lu,mode,n,ia,ib)
c
c $$$$$ calls assign, iargc, and getarg $$$$$
c
c Asnag1 assigns logical unit lu to a direct access disk file
c with mode "mode" and record length "len". See dasign for
c details. The n th argument is used as the model name. If there
c is no n th argument and ib is non-blank, it is taken to be the
c model name. If ib is blank, the user is prompted for the
c model name using the character string in variable ia as the
c prompt. Programmed on 8 October 1980 by R. Buland.
c
save
logical log
character*(*) ia,ib
c..................
c all argument parameters are set and treated in the main
c porgram. if a different model was chosen it is allready
c conatine in the array ib.
c
c integer iargc
c
c if(iargc(i).lt.n) go to 1
c if(iargc( )-1.lt.n) go to 1 !no argument on HP-UX m.b
c !on SUN iargc starts with 0
c !on HP iargc starts with 1
c call getarg(n,ib)
c go to 2
c
c 1 if(ib.ne.' ') go to 2
c call query(ia,log)
c read(*,100)ib
c 100 format(a)
c
2 nb=index(ib,' ')-1
if(nb.le.0) nb=len(ib)
call assign(lu,mode,ib(1:nb)//'.hed')
return
end |
compilation subroutine fparm, get_opt et check_opt manquantes
Répondre avec citation
Partager