[Fortran] 纯文本查看 复制代码
implicit none
integer yr,hr,min,mo,dy
integer*4 trimlen,
& narguments,iargc
real mag
real herr, verr, res
character line*180, fn0*80
character fn1*30
logical ex
logical iy2k !T for y2k format, F for old format
logical ipos1 !is P or S
logical ipos2 !is P or S
logical ipos3 !is P or S
logical ipos4 !is P or S
logical zc
real t_time ! travel time
real p_wghtr !P weight derived from assigned code
real s_wghtr !s weight derived from assigned code
integer wghtr !weight
character sta*4 !full station code
integer*4 cuspid, date,num
real sec,lon, deglat, deglon, lat
real depth
character str30*30
character ph*4
character ph1*1
character ph2*1
character ph3*1
character ph4*1
character ew*1
character ns*1
c IFX
integer*1 ifx
integer*8 k
c-- get input file name:
call getarg (1,str30)
fn0= str30 (1:trimlen(str30))
open (1,file=fn0, status='unknown')
c-- open output file name:
call getarg (2,str30)
fn1= str30(1:trimlen(str30))
open (2,file=fn1,status='unknown')
c-- read header
num=1
k=1
100 read(1,'(a)',end=200)line ! read header line
iy2k= (line(1:1).eq.'#')
c iy2k= (line(3:4).eq.'19' .or. line(3:4).eq.'20')
if(iy2k) then
read(line(5:6),'(i2)')yr
read(line(8:9),'(i2)')mo
read(line(11:12),'(i2)')dy
read(line(14:15),'(i2)')hr
read(line(17:18),'(i2)')min
read(line(20:24),'(f5.2)')sec
read(line(27:33),'(f6.3)')deglat
read(line(36:42),'(f7.3)')deglon
read(line(47:51),'(f5.2)')depth
read(line(53:56),'(f3.1)')mag
lat= deglat
lon= deglon
herr=0.00
verr=0.00
res=0.00
cuspid=num
num=num+1
ns='N'
ew='E'
ifx=0
c--Write earthquake location line
write (2,60) yr,mo,dy,hr,min,sec,lat,ns,lon,ew,depth,mag
goto 100
else
goto 105
endif
c--Form station code
105 sta=(line(1:4))
c ph= (line(49:52))
c ph1= (line(49:49))
c ph2= (line(50:50))
c ph3=(line(51:51))
c ph4=(line(52:52))
ph=(line(27:27))
read (line(10:15),'(f7.2)') t_time !min for both p & s
wghtr=0
c ipos1=((ph1.eq.'P').or.(ph2.eq.'P').or.(ph3.eq.'P'))
ipos1=(ph.eq.'P')
zc=(mod(k,6).eq.0)
if(zc) then
write (2,*)
endif
if(ipos1) then
write (2,61) sta,'P',wghtr,t_time
k=k+1
endif
goto 100
c--Earthquake location format.
60 format (/3i2,1x,2i2,1x,f5.2,1x,f7.4,a1,1x,f8.4,a1,1x,f7.2,
1 2x,f5.2 )
c--Phase format
61 format (a4,a1,i1,1x,f5.2,$)
200 close(1)
close(2)
end
integer function TRIMLEN(t)
c------------------------------------------------------------------
c Author: Urs Kradolfer, June 1986
c Call: nc=TRIMLEN(char)
c
c --> nc says, how many characters the input-string has
c (ignoring trailing blanks!).
c
implicit none
c
character t*(*)
do 1 trimlen=LEN(t),1,-1
1 if(t(trimlen:trimlen).ne.' ')RETURN
trimlen=1
end ! of integer function trimlen
c