eugen
not sure what the problem is with isfnor,have not used it for a long time.
lars should know.
i have used norims lately. it works with the output from the ISC screen. i
attach latest version where a few things have been fixed.
jens
On Fri, 31 Jul 2015, Eugen OROS wrote:
Hi everybody
I obtained a ISC bulletin, ISF format.
I used isfnor routine to convert this ISF bulletin to Seisan format.
It does not work.
The following lines appear into dos windows for all lines of the ISF bulletin.
Where I have a mistake?
Help me please
<a href="http://www.isc.ac.uk/cgi-bin/stations?stacode=BZS";>BZS</a> 1.29 237
.5 P 11:11:05.128 ___
__ 98756118
following line not recognized:
<a href="http://www.isc.ac.uk/cgi-bin/stations?stacode=BZS";>BZS</a> 1.29 237
.5 S 11:11:21.542 ___
__ 98756119
following line not recognized:
<a href="http://www.isc.ac.uk/cgi-bin/stations?stacode=BZS";>BZS</a> 1.29 237
.5 Pb 11:11:05.128 0.1 ___
__ 98763278
following line not recognized:
<a href="http://www.isc.ac.uk/cgi-bin/stations?stacode=VOIR";>VOIR</a> 1.58 12
3.3 P 11:11:08.745 ___
__ 98756126
Thank you
Eugen
c Program imsnor
c To exchange info with IMS1.0:SHORT.
c
c Mario Villagran, March 2001
c IDC-Vienna
c International Data Centre
c
c converts nordic format files into IMS1.0:SHORT format
c as specified in the IDC Formats and Protocols to submit information
c to the IDC and viceversa.
c
c Input: nordic or IMS1.0:SHORT format file
c
c if input is nordic, the corresponding hyp.out
c and print.out are necesary as well as a correlative
c number to identify the event in IMS1.0:SHORT format.
c
c if input is IMS1.0:SHORT no more info is needed.
c
c Oputput: IMS1.0:SHORT or nordic format file
c
c comments: When CONVERTING from nordic to IMS1.0:SHORT
c
c vector printout(1000*flines) contains space for
c 700*flines print.out lines of an event
c 300*flines nordic file lines
c
c comments: When CONVERTING from IMS1.0:SHORT to nordic
c
c vector printout(1000*flines) contains space for
c nordic file lines
c
c To extend the capacity you have to change
c the parameter flines (factor to increase
c the size of the array 1, 2 ,3....).
c
c Changes:
c 2001 july 5 jh : make distance real, help from mario
c 2007 04 26 : optionally put out a * for no location flag,
c look for varibale
c 2008 09 16 jh: make sure all lock flags are F, not f. also Mb changed to
c MB, limit number of stations to 999
c 2008 09 26 jh. soem d flag was appearing in fixf, removed
c 2008 10 07 jh transfer first 6 chars of phase instead og 6 from ims, fix
pdif
c 2010 mar 9 jh: i to il in read statement, was already done
c 2010 apr 27 jh: B to b and S to s in magnitudes
c 2012 feb 20 jh: problem with end of file
c 2012 sep 28 jh: another ----------------
c 2015 may 14 jh: sligt change in input format, skip events with comments in
phases
c 2015 jul 22 jh: phases were skipped if no magnitude lines, take out the
weighting
c cannot find documentation. program was using info inder
Def. if 'T'
c weight 0, if _, weight 4, seems lik elocated event all
have T
c
implicit none
c
c size of working array
integer flines
parameter (flines=10)
c-- arguments, input file, location agency and mag agencies.
character*136 printout(1000*flines),text !SEE comments BEFORE
character*80 args(10),infile,printhyp,region,top_directory
character*80 cjunk,nordorg(50)
character*30 ttext
character fecha*12,fechax*22,numero*8,sta*5,ph*4,junk*8
character lage*7,ph_out*6
character*11 msta(150)
character*3 prefage,age1,age2,age3,def,mage(9)
c--crustal model, type of event, id of event,kind of magnitudes.
character*1 model,type,id,fixd,cd,uno,am,undsc,timf,locf
character*2 mc,mc1,mc2,mc3,mc4,evex,pl
character*2 cmg(9)
real mg(9)
c--time variables, hypocentral parameters and magnitudes.
integer year,mo,dy,hr,mn,npha,nsta,number,gap,az,wg
integer nsm1,nsm2,nsm3,nsm4,n,dist,reg,kstop,phnumber
real xdist
real mag,mag1,mag2,mag3,mag4,hdist,smag,sbmag,snr
real sec,lat,lon,dep,rms,tres,velo
real ermag1,ermag2,ermag3,x1,x2,x3,mw,smw,azph,raz
real ermg(9)
integer nm(9),nmags
real timerr,x,smajor,sminor,erd,dmin,dmax,amp,per
c--ML,Mb
real a,b,c,d,smsta,q,equrad,polrad,pi,rad,radius
parameter (equrad = 6378.2064)
parameter (polrad = 6356.5838)
parameter (pi = 3.14159265)
parameter (rad = pi/180.)
integer*4 stime,tarray(9),time,nmsta,inumid
character*12 t1 ! for seisan system time
character*14 t2 ! ---------------------
character*1 lock ! to lock location
c---ellipse error
real ery,erx,erz,cvxy,cvxz,cvyz
c---number of arguments and counters
integer nars,ncards,i,j,k,ncard,npcard,namp,work,karr,jarr,nmw
integer nbamp,kk,kkk
c--compact or not
logical compact
c--computer type
logical pc, sun,linux
c---
c
c
c print version
c
include 'version.inc'
out_version_date='July 23, 2001'
if (version_new) out_version_date=version_date
call print_ver
call computer_type(sun,pc,linux)
c
c check if input from file given in argument
c display help if necesary
c
call get_arguments(nars,args)
if (nars.eq.0) then
write(6,*) ' Choose option: '
write(6,*) ' IMS1.0:SHORT -> nordic (1) or '
write(6,*) ' nordic -> IMS1.0:SHORT (2)'
read(*,'(a)') args(1)
if (args(1).eq.'1') then
write(*,*) ' IMS1.0:SHORT input file '
read(*,'(a)') args(2)
elseif (args(1).eq.'2') then
write(*,*) ' Nordic input file '
read(*,'(a)') args(2)
write(*,*) ' Hypocenter output file (default=print.out)'
read(*,'(a)') args(3)
if (args(3).eq.' '.or.args(3).eq.'') args(3)='print.out'
write(*,*) ' Number of first event'
read(*,'(a)') args(4)
write(*,*) ' Number of first phase'
read(*,'(a)') args(5)
endif
elseif (nars.eq.1.and.args(0).eq.'-help') then
5 write(6,*)' '
write(6,*)' You must define the desired convertion type,'
write(6,*)' input files and id number (this last only case 2)'
write(6,*)' 1 for IMS1.0:SHORT------> nordic or'
write(6,*)' 2 for nordic------> IMS1.0:SHORT'
write(6,*)' examples:'
write(6,*)' '
write(6,*)' norims 1 xx.inp'
write(6,*)' '
write(6,*)' This converts file xx.inp from IMS1.0:SHORT to'
write(6,*)' nordic output is file norims.nor'
write(6,*)' '
write(6,*)' norims 2 hyp.out print.out 35 850'
write(6,*)' '
write(6,*)' This creates a IMS1.0:SHORT file from the hyp.out'
write(6,*)' and print.out files and gives to the first event '
write(6,*)' in list the number 35, and 850 to the first phase'
write(6,*)' if number is not defined 001 is the default'
write(6,*)' for both, output is file norims.ims and compact.ims'
write(6,*)' '
stop
endif
c
c check arguments
c get input file names and decides what to do
c open files
c
pl='+-'
read(args(1),'(i1)',err=5)work
if((work.eq.1.and.nars.gt.2).or.(nars.gt.5).or.
*(work.gt.2).or.(work.lt.1))then
write(6,*)' Wrong arguments !!!!!!!!!!!'
write(6,*)' '
goto 5
endif
infile=args(2)
open(1,file=infile,status='old')
c stime=time()
call systime(t1,t2) ! seisan general routine
read(t1,'(5i2)') (tarray(i),i=6,2,-1)
c call gmtime(stime, tarray) !GMT time
write(ttext(1:30),'(a7,i4,3(a1,i2),i2,a8)')
*'MSG_ID ',tarray(6)+2000,'/',tarray(5)+1,'/',tarray(4),'_',
*tarray(3),tarray(2),' IDC_NDC'
do i=13,22 !fill blanks
if(ttext(i:i).eq.' ')ttext(i:i)='0'
enddo
if(work.eq.1)goto 50
c
c HERE STARTS CONVERTING FROM NORDIC TO IMS1.0:SHORT
c
printhyp=args(3)
read(args(4),'(i5)',err=6)number
6 if(number.eq.0)number=1
read(args(5),'(i5)',err=7)phnumber
7 if(phnumber.eq.0)phnumber=1
open(7,file=printhyp,status='old')
open(2,file='norims.ims',status='unknown')
open(4,file='compact.ims',status='unknown')
c
c check if it is a correct s-file
c
call nortype(1,compact)
if(compact) then
write(6,*)' The file must be an F-file'
stop
endif
c
c Gets the time at which the file is done if sun GMT time
c note that on pc the time is local unless some extra-arrangement
c WRITE IMS1.0:SHORT EXCHANGE DATA LINES
c
write(2,'(a12)')'BEGIN IMS1.0'
write(2,'(a13)')'MSG_TYPE DATA'
write(2,'(a30)')ttext(1:30)
write(2,'(a23)')'DATA_TYPE BULLETIN IMS1.0:SHORT'
write(4,'(a12)')'BEGIN IMS1.0'
write(4,'(a13)')'MSG_TYPE DATA'
write(4,'(a30)')ttext(1:30)
write(4,'(a23)')'DATA_TYPE BULLETIN IMS1.0:SHORT'
c
c NORDIC ----> IMS1.0:SHORT BIG LOOP STARTS HERE
c
n=0 ! number of processed events
a=1.00 ! default calculation of ML is
b=1.11 ! Hutton & Boore, a,b,c,d
c=0.00189
d=-1.9680
c magnitude constants for ML (check if other values in STATION0.HYP)
call topdir(top_directory)
i=index(top_directory,' ')-1
text(1:i+17)=top_directory(1:i)//'/DAT/STATION0.HYP'
open(8,file=text(1:i+17),status='old')
8 read(8,'(a)')text(1:40)
if(text(1:5).eq.'RESET')then
if(text(12:13).eq.'75')read(text(16:),*)a
if(text(12:13).eq.'76')read(text(16:),*)b
if(text(12:13).eq.'77')read(text(16:),*)c
if(text(12:13).eq.'78')read(text(16:),*)d
endif
close(8)
c
c initialize variables
c
10 continue
mc1(1:2)=' '
mc2(1:2)=' '
mc3(1:2)=' '
mc4(1:2)=' '
mag1=0.0
mag2=0.0
mag3=0.0
mag4=0.0
ermag1=0.0
ermag2=0.0
ermag3=0.0
region(1:80)=' '
nsta=0
npha=0
dmax=0.0
dmin=15000.00
undsc='_'
lage=' '
c
c GET NECESARY INFORMATION FROM print.out AND THE F-file
c
ncards=1
15 read(7,'(a80)',end=99)printout(1)(1:80)
if(printout(1)(1:8).eq.' EVENT #')goto 20
goto 15
20 ncards=ncards+1
read(7,'(a80)')printout(ncards)(1:80)
if(printout(ncards)(1:10).eq.'----------')goto 28
c
c displays possible errors and stop the program
c
if(ncards.gt.650*flines)then
write(6,*)printout(1)(1:20),'to many print.out lines!!'
write(6,*)'to solve this, edit norims.f, read comments'
goto 99
22 write(6,*)'print.out and S-file not matching !!!'
24 goto 99
endif
goto 20
28 continue
do i=1,ncards
if(printout(i)(1:19).eq.' Origin time error:')
* read(printout(i)(20:60),*)timerr
if(printout(i)(1:18).eq.' date hrmn sec')
* read(printout(i+1)(1:80),'(73x,f5.1)')erd
if(printout(i)(6:19).eq.'multiple-phase')
* read(printout(i)(1:5),'(i5)')npha
if(printout(i)(1:14).eq.' Azimuthal Gap')
* read(printout(i)(36:38),'(i3)')gap
if(printout(i)(1:17).eq.' stn dist azm')then
do j=i+1,ncards
if(printout(j)(1:3).eq.' ')goto 30
read(printout(j)(1:11),'(7x,i4)')k
if(dmax.lt.k)dmax=k
if(dmin.gt.k)dmin=k
enddo
endif
30 continue
enddo
c
c read info from current event and
c place the file ready to read next event
c
ncard=700*flines !reserve 701*flines to 1000*flines for nordic
namp=0
nbamp=0
nsm4=0
npcard=0
k=0
smag=0.0
sbmag=0.0
smw=0.0
nmw=0
nmsta=0
smsta=0
35 read(1,'(a80)',end=22)text(1:80)
if(text(1:20).eq.' '.
* and.text(80:80).eq.' ')goto 40
ncard=ncard+1
if(k.eq.0)then
if(text(80:80).eq.'1'.or.text(80:80).eq.' ')then
if(text(22:22).eq.'L'.or.text(22:22).eq.'R'.or.
* text(22:22).eq.'D')then
read(text(1:80),100)year,mo,dy,hr,
* mn,sec,model,type,id,lat,lon,dep,fixd,lage(5:7),nsta,
* rms,mag1,mc1(2:2),age1,mag2,mc2(2:2),age2,mag3,
* mc3(2:2),age3,uno
if(mc1(2:2).eq.'C')mag1=0.0 !MC = MD
if(mc1(2:2).eq.'C')mc1(2:2)=' ' !to avoid repetition
if(mc2(2:2).eq.'C')mag2=0.0
if(mc2(2:2).eq.'C')mc2(2:2)=' '
if(mc3(2:2).eq.'C')mag3=0.0
if(mc3(2:2).eq.'C')mc3(2:2)=' '
k=1
endif
endif
endif
if(text(80:80).eq.'E')
* read(text(1:80),'(23X,F7.3,1X,F7.3,F5.1,3E12.4)')
* ery,erx,erz,cvxy,cvxz,cvyz
if(text(2:15).eq.'Ellipse_as_IDC')
* read(text(1:80),'(16x,2(f6.1,1x),i3)')smajor,sminor,az
c statistics for MW
if(text(80:80).eq.'3'.and.text(7:11).ne.'AVERA'.and.
* text(72:73).eq.'MW')then
read(text(75:78),'(f4.1)')mw
if(mc1(2:2).eq.'W')mag=mag1
if(mc2(2:2).eq.'W')mag=mag2
if(mc3(2:2).eq.'W')mag=mag3
nmw=nmw+1
smw=smw+(mw-mag)**2
endif
c get stations with MD
if(text(80:80).eq.'3'.and.text(2:2).eq.'$')then
nmsta=nmsta+1
msta(nmsta)=text(3:13)
read(msta(nmsta)(9:11),'(f3.1)')x1
smsta=smsta+x1
endif
c
c NOTE:
c get standard deviation of IPRG magnitude and number of stations
c used to get it, this in case that s-file was obtained/converted
c from iprg format to nordic (using isrnor), IF NOT ermag3 and nsm4
c are obtained later when converting the arrivals.(see ARRIVAL LINES)
c
if(text(1:5).eq.' O.T.')then
do i=20,60
if(text(i:i+3).eq.'ML =')
* read(text(i+5:i+19),'(f3.1,4x,f3.1,3x,i2)')mag4,ermag3,nsm4
enddo
endif
c sign where arrival lines start (appended on March 18,1997) m.v.
if(text(1:5).eq.' STAT')npcard=ncard+1
c get number of amplitudes and stand dev of MLs
if(mc1(2:2).eq.'L')mag=mag1
if(mc2(2:2).eq.'L')mag=mag2
if(mc3(2:2).eq.'L')mag=mag3
if(npcard.gt.0.and.text(34:40).ne.' '.and.
* text(34:40).ne.' AMPLIT')then
read(text(1:80),'(33x,g8.1,f4.1,25x,f5.0)')amp,per,xdist
xdist=dist
hdist=sqrt(real(dist)*real(dist)+dep*dep)
if(amp.gt.0.0.and.per.lt.5.0)then
if(text(11:11).ne.'P')then
namp=namp+1
smag=smag+(a*alog10(amp)+b*alog10(hdist)+c*hdist+d-mag)**2
else
nbamp=nbamp+1
hdist=real(dist)/111.2 ! hdist is distance in deg
call mb_att(dep,hdist,q)
sbmag=sbmag+alog10(amp/per)+q
amp=0.0
endif
endif
endif
c region
if(text(1:2).eq.' *')then
do i=3,80
if(text(i:i).eq.'*')then
region(1:)=text(4:i-2)
call sei upc(region)
goto 39
endif
enddo
endif
c copy the f-file
39 printout(ncard)(1:80)=text(1:80)
goto 35
c
c arrange magnitudes
c
40 continue
if(mc1(2:2).ne.' ')mc1(1:1)='M'
if(mc2(2:2).ne.' ')mc2(1:1)='M'
if(mc3(2:2).ne.' ')mc3(1:1)='M'
if(mag4.gt.0.0)mc4(1:2)='MD'
c
c get ellipse dimensions
c
npha=npha+nsta
c
c writes date in "fecha" variable and fill blanks with zeros
c
write(fechax(1:22),'(i4,2(a1,i2),1x,2(i2,a1),f5.2)')
* year,'/',mo,'/',dy,hr,':',mn,':',sec
do i=1,22
if(fechax(i:i).eq.' ')fechax(i:i)='0'
enddo
fechax(11:11)=' '
c
c prepares the event id line in IMS1.0:SHORT format
c
numero(1:8)=' '
write(numero(1:8),'(i8)')number
do i=1,8
if(numero(i:i).eq.' ')numero(i:i)='0'
enddo
c EVENT and REGION ID LINE (if) !!start writing here
write(2,'(a5,1x,a8,1x,a50)')'EVENT',numero(1:8),region(1:50)
write(4,'(a5,1x,a8,1x,a50)')'EVENT',numero(1:8),region(1:50)
c HEADER EVENT LINES
write(2,150)
write(4,150)
c ORIGIN LINE
if(nmsta.gt.0)then
mc4='MD'
nsm4=nmsta
mag4=smsta/float(nmsta)
smsta=0.0
do k=1,nmsta
read(msta(nmsta)(9:11),'(f3.1)')x1
smsta=smsta+(x1-mag4)**2
enddo
ermag3=sqrt(smsta/nmsta)
endif
if(fixd.eq.'f')fixd='F'
write(text(1:136),250)fechax(1:22),timerr,rms,lat,lon,smajor,
* sminor,az,dep,fixd,erd,npha,nsta,gap,lage(5:7),numero
radius = cos(lat)**2/equrad**2
radius = (radius +sin(lat)**2/polrad**2)**(-.5)
dmin = real(dmin)/(radius*rad)
dmax = real(dmax)/(radius*rad)
write(text(97:110),'(2f7.2)')dmin,dmax
evex='se'
if(id.eq.' '.and.mag4.gt.2.5)evex='ke'
if(id.eq.'E')evex='km'
if(id.eq.'P')evex='sm'
write(text(111:117),'(a4,1x,a2)')' m i',evex
write(2,'(a)')text(1:136)
write(4,'(a)')text(1:136)
c BLANK LINE
write(2,*)' '
write(4,*)' '
c MAGNITUDE HEADER LINE
write(2,'(a)')'Magnitude Err Nsta Author OrigID'
write(4,'(a)')'Magnitude Err Nsta Author OrigID'
c MAGNITUDE LINES (if)
text(1:38)=' '
if(mc1.ne.' ')then
write(text(1:38),310)mc1,mag1,numero
if(mc1(2:2).eq.'B')write(text(1:2),'(a2)')'mb'
if(mc1(2:2).eq.'S')write(text(1:2),'(a2)')'Ms'
if(mc1(2:2).eq.'W')write(text(1:2),'(a2)')'Mw'
if(mc1(2:2).eq.'L')write(text(16:19),'(i4)')namp
if(mc1(2:2).eq.'B')write(text(16:19),'(i4)')nbamp
if(mc1(2:2).eq.'L'.and.namp.gt.1)
* write(text(12:14),'(f3.1)')sqrt(smag/namp)
if(mc1(2:2).eq.'B'.and.nbamp.gt.1)
* write(text(12:14),'(f3.1)')sqrt(sbmag/nbamp)
if(mc1(2:2).eq.'W'.and.nmw.gt.1)
* write(text(12:14),'(f3.1)')sqrt(smw/nmw)
if(text(18:19).eq.' 0')text(18:19)=' '
write(2,'(a38)')text(1:38)
write(4,'(a38)')text(1:38)
endif
if(mc2.ne.' ')then
write(text(1:38),310)mc2,mag2,numero
if(mc2(2:2).eq.'B')write(text(1:2),'(a2)')'mb'
if(mc2(2:2).eq.'S')write(text(1:2),'(a2)')'Ms'
if(mc2(2:2).eq.'W')write(text(1:2),'(a2)')'Mw'
if(mc2(2:2).eq.'L')write(text(16:19),'(i4)')namp
if(mc2(2:2).eq.'B')write(text(16:19),'(i4)')nbamp
if(mc2(2:2).eq.'L'.and.namp.gt.1)
* write(text(12:14),'(f3.1)')sqrt(smag/namp)
if(mc2(2:2).eq.'B'.and.nbamp.gt.1)
* write(text(12:14),'(f3.1)')sqrt(sbmag/nbamp)
if(mc2(2:2).eq.'W'.and.nmw.gt.1)
* write(text(12:14),'(f3.1)')sqrt(smw/nmw)
if(text(18:19).eq.' 0')text(18:19)=' '
write(2,'(a38)')text(1:38)
write(4,'(a38)')text(1:38)
endif
if(mc3.ne.' ')then
write(text(1:38),310)mc3,mag3,numero
if(mc3(2:2).eq.'B')write(text(1:2),'(a2)')'mb'
if(mc3(2:2).eq.'S')write(text(1:2),'(a2)')'Ms'
if(mc3(2:2).eq.'W')write(text(1:2),'(a2)')'Mw'
if(mc3(2:2).eq.'L')write(text(16:19),'(i4)')namp
if(mc3(2:2).eq.'B')write(text(16:19),'(i4)')nbamp
if(mc3(2:2).eq.'L'.and.namp.gt.1)
* write(text(12:14),'(f3.1)')sqrt(smag/namp)
if(mc3(2:2).eq.'B'.and.nbamp.gt.1)
* write(text(12:14),'(f3.1)')sqrt(sbmag/nbamp)
if(mc3(2:2).eq.'W'.and.nmw.gt.1)
* write(text(12:14),'(f3.1)')sqrt(smw/nmw)
if(text(18:19).eq.' 0')text(18:19)=' '
write(2,'(a38)')text(1:38)
write(4,'(a38)')text(1:38)
endif
if(mag4.gt.0.0)then
write(text(1:38),310)mc4,mag4,numero
write(text(16:19),'(i4)')nsm4
write(text(12:14),'(f3.1)')ermag3
if(text(18:19).eq.' 0')text(18:19)=' '
write(2,'(a38)')text(1:38)
write(4,'(a38)')text(1:38)
endif
c BLANK LINE
write(2,*)' '
write(4,*)' '
c HEADER ARRIVAL LINE
if(ncard-npcard.gt.0)then
write(2,220)
c ARRIVAL LINES
do i=npcard,ncard
amp=0.0
mag=0.0
def='___'
mc(1:2)=' '
read(printout(i)(2:80),1201)sta,ph,wg,cd,hr,mn,sec,amp,
* per,azph,velo,snr,k,tres,xdist,az
raz=real(k)
dist=xdist
if(printout(i)(15:15).ne.'4'.and.printout(i)(11:11).ne.' '.
* and.printout(i)(11:11).ne.'T')def(1:1)='T'
am='m'
if(printout(i)(16:16).eq.'A')am='a'
cd='_'
if(cd.eq.'C')cd='c'
if(cd.eq.'D')cd='d'
hdist=sqrt(real(dist)*real(dist)+dep*dep)
if(amp.gt.0.0.and.per.lt.5.0)then
mag=a*alog10(amp)+b*alog10(hdist)+c*hdist+d
mc='ML'
if(ph(1:1).eq.'P')then
hdist=real(dist)/(radius*rad) ! hdist is distance in deg
call mb_att(dep,hdist,q)
mag=alog10(amp/per)+q
mc='Mb'
endif
endif
write(fechax(11:22),'(2(i2,a1),f6.3)')hr,':',mn,':',sec
do k=11,22
if(fecha(k:k).eq.' ')fecha(k:k)='0'
enddo
mc4=' '
if(nmsta.gt.0)then
do k=1,nmsta
if(sta(1:4).eq.msta(k)(1:4))then
read(msta(k)(9:11),'(f3.1)')mag4
mc4='MD'
endif
enddo
endif
write(numero(1:8),'(i8)')phnumber
do k=1,8
if(numero(k:k).eq.' ')numero(k:k)='0'
enddo
c easy convertion from km to deg...not so accurate.
x3 = real(dist)/(radius*rad)
write(text(1:122),140)sta,x3,real(az),ph,fechax(11:22),tres,
* azph,raz,velo,def,snr,amp,per,am,cd,undsc,mc,mag,numero
140 format(a5,1x,f6.2,f6.1,1x,a4,5x,a12,3f6.1,1x,f6.1,
* 8x,a3,f6.1,f10.1,f6.2,1x,2a1,a1,1x,a2,4x,f4.1,1x,a8)
if(text(104:105).eq.' ')write(text(104:113),'(a2,4x,f4.1)')
* mc4,mag4
if(text(20:20).eq.' ')text(42:46)=' '
if(text(89:98).eq.' 0.0 0.00')text(89:98)=' '
if(text(110:113).eq.' 0.0')text(110:113)=' '
if(azph.eq.0.0)text(47:58)=' '
if(azph.gt.0.0)text(75:75)='A'
if(velo.eq.0.0)text(61:65)=' '
if(velo.gt.0.0)text(76:76)='S'
if(wg.eq.4)text(75:76)='__'
if(snr.eq.0.0)text(78:82)=' '
if(raz.eq.0.0)text(53:58)=' '
write(2,'(a)')text(1:122)
phnumber=phnumber+1
enddo
endif
c BLANK LINE
write(2,*)' '
n=n+1
number=number+1
goto 10
c end of BIG LOOP
c
c HERE STARTS IF CONVERTING FROM IMS1.0:SHORT TO NORDIC
50 open(2,file='norims.nor',status='unknown')
write(*,*)' Which agency you prefer for nordic first header?'
write(*,*)' 3 chars....(ex. ISC) or enter for any'
read(*,'(a)') prefage
write(6,*) ' Set no location flag (y/n=default)'
read(5,'(a1)') lock
if(lock.ne.'y'.and.lock.ne.' ') lock=' '
if(lock.eq.'y') lock='*'
n=0 !number of events
ncards=i
ncard=0
kstop=0
c
c-----------------------------------------------------------------------------
c IMS1.0:SHORT ----> NORDIC BIG LOOP STARTS HERE
c-----------------------------------------------------------------------------
c
c NEW EVENT
c
c the variables printout(1*flines)-->printout(350*flines)
c are reserved for lines above the nordic line type 7 (also included
c and printout(351*flines)-->printout(999*flines) for arrival lines
c
c
write(printout(1000*flines)(1:80),'(a,a)')
*' STAT SP IPHASW D HRMM SECON CODA AMPLIT PERI AZIMU ',
c *'VELO SNR AR TRES W DIS CAZ7'
*'VELO AIN AR TRES W DIS CAZ7'
60 continue
karr=350*flines !the arrival's counter
j=0 !the header's counter
jarr=1 !defines if input is short or long input file
dmax=0.0
dmin=15000.00
cmg(1)='Mb'
cmg(2)='Ms'
cmg(3)='ML'
cmg(4)='MD'
cmg(5)='Ml'
cmg(6)='MN'
cmg(7)='MG'
cmg(8)='Ms'
cmg(9)='Mb'
timf=' '
locf=' '
do i=1,9
mg(i)=0.0
ermg(i)=0.0
nm(i)=0
enddo
mc1(1:2)=' '
mc2(1:2)=' '
mc3(1:2)=' '
mag1=0.0
mag2=0.0
mag3=0.0
nmags=0
nsta=0
65 continue
read(1,'(a)',end=99)text
if(text(1:4).eq.'STOP')then
if(n.eq.0)then
write(6,*)'No events were found in input file !!!'
68 write(6,*)'Error, Check event # ',n
endif
goto 99
endif
c
c Identifies that there is an event, creates location line
c of nordic format and ID line
c
if(text(1:6).eq.'EVENT '.or.text(1:6).eq.'Event ')then
n=n+1
cxx
write(6,*) text(1:60)
read(text(7:),*)inumid,cjunk(1:50)
read(text(7:),'(a50)')region(1:50)
reg=0
endif
if(text(4:18).eq.'Date Time')then !LONG IG starts here
c allows more than 1 blank line after header (german ims reports case)
c Aug 19, 1997....m.v.
69 read(1,'(a)',end=99)text !reads blank lines
if(text(5:5).eq.'/')then
backspace(1)
c read first header line
read(1,255,end=99,err=68)year,mo,dy,hr,mn,sec,timf,timerr,
* rms,lat,lon,locf,smajor,sminor,az,dep,fixd,erd,npha,nsta,
* gap,x1,x2,text(1:3),evex,lage,numero
do i=1,3
if(lage(i:i).eq.' '.or.lage(i:i).eq.'_')lage(i:i)='X'
enddo
if(fixd.eq.'f')fixd='F'
c line type 1
j=j+1
c
c check if not oo many stations
c
if(nsta.gt.999) nsta=999
c
write(printout(j),101)year,mo,dy,hr,mn,sec,' ','R',' ',lat,
* lon,dep,fixd,lage(1:3),nsta,rms,'1'
if(evex.eq.'km')printout(j)(23:23)='E'
if(evex.eq.'sm')printout(j)(23:23)='P'
do i=7,18
if(printout(j)(i:i).eq.' ')printout(j)(i:i)='0'
enddo
c jh
if(printout(j)(44:44).ne.' '.and.printout(j)(44:44).ne.'F')
* printout(j)(44:44)=' '
if(printout(j)(45:45).ne.' '.and.printout(j)(45:45).ne.'F')
* printout(j)(45:45)=' '
if(timf.eq.'f') timf='F'
printout(j)(11:11)=timf(1:1)
printout(j)(16:16)=' '
if(locf(1:1).eq.'f') locf(1:1)='F'
printout(j)(45:45)=locf(1:1)
c
c not date line, something with (
c
elseif(text(2:2).eq.'(')then
700 j=j+1 !This case for info between brackets in the middle
write(printout(j),'(1x,a2,a70,a3,3x,a1)') !of origin lines
* '* ',text(1:70),'***','3'
do i=2,136
if(text(i:i).eq.')')goto 69
enddo
read(1,'(a)',end=70)text
goto 700
c
c blank line
c
elseif(text(1:5).eq.' ')then
if(prefage.ne.' ')then
kk=0 !sorts origin lines if a prefered agency exists
do i=1,j
if(printout(i)(46:48).eq.prefage)then
kk=kk+1
nordorg(kk)(1:80)=printout(i)(1:80)
printout(i)(1:5)='IMOUT'
endif
enddo
do i=1,j
if(printout(i)(1:5).ne.'IMOUT')then
kk=kk+1
nordorg(kk)(1:80)=printout(i)(1:80)
endif
enddo
do i=1,j
printout(i)(1:80)=nordorg(i)(1:80) !done
enddo
endif
goto 70
endif
goto 69
c read second header line, could be magnitude
70 continue
read(1,'(a)',end=73)text !reads blank lines
if(text(1:5).eq.'Event'.or.text(1:5).eq.'EVENT')then
backspace(1) !This in case that there are no magnitudes
goto 73
endif
c
c also check for phases, there might not be magnitudes
c
if(text(1:7).eq.'Sta ') then
backspace(1)
goto 73
endif
if(text(1:14).ne.'Magnitude Err')goto 70
c
c gets magnitude line by line, only done for Ms, mb and ML.....
c
71 read(1,'(a)',end=99)text
if(text(1:4).eq.' ')goto 72
if(text(1:1).eq.'m'.or.text(1:1).eq.'M')then
if(text(2:4).eq.'b ')
* read(text(1:23),300,err=68)mg(1),ermg(1),nm(1),mage(1)
if(text(2:4).eq.'s ')
* read(text(1:23),300,err=68)mg(2),ermg(2),nm(2),mage(2)
if(text(2:4).eq.'L ')
* read(text(1:23),300,err=68)mg(3),ermg(3),nm(3),mage(3)
if(text(2:4).eq.'D ')
* read(text(1:23),300,err=68)mg(4),ermg(4),nm(4),mage(4)
if(text(2:4).eq.'l ')
* read(text(1:23),300,err=68)mg(5),ermg(5),nm(5),mage(5)
if(text(2:4).eq.'N ')
* read(text(1:23),300,err=68)mg(6),ermg(6),nm(6),mage(6)
if(text(2:4).eq.'bLg')
* read(text(1:23),300,err=68)mg(7),ermg(7),nm(7),mage(7)
if(text(2:4).eq.'S ')
* read(text(1:23),300,err=68)mg(8),ermg(8),nm(8),mage(8)
if(text(2:4).eq.'B ')
* read(text(1:23),300,err=68)mg(9),ermg(9),nm(9),mage(9)
goto 71
endif
72 continue
c magnitudes insertion work
kk=56
kkk=1
do k=1,9 ! At the moment only 9 kinds of magnitude are parsed
if(mg(k).gt.0.0.and.kk.le.72)then
write(printout(kkk)(kk:kk+7),'(f4.1,a1,a3)')
* mg(k),cmg(k)(2:2),mage(k)
kk=kk+8
endif
if(kk.gt.72)then
kk=56
kkk=kkk+1
if(kkk.gt.j)goto 73
endif
enddo
c line type I
73 continue
write(printout(j+1)(1:80),'(a12,a11,1x,a2,a34,i4,5i2,a6)')
* ' ACTION:REG ',ttext(10:20),ttext(21:22),
* ' OP:nims STATUS: ID:',year,mo,dy,hr,mn,
* int(sec),' I'
printout(j+1)(15:15)='-'
printout(j+1)(18:18)='-'
printout(j+1)(21:21)=' '
printout(j+1)(24:24)=':'
do i=61,74
if(printout(j+1)(i:i).eq.' ')printout(j+1)(i:i)='0'
enddo
c
c This line to keep some extra information from IDC that nordic
c format does not have specific fields...ellipse and qk ID
write(printout(j+2),'(1x,a13,2(f6.1,1x),i3,a9,f5.1,12x,
* a9,i8,5x,a1)')'IDC: ellipse ',smajor,sminor,az,' MB sd+- ',
* ermg(1),'Event ID ',inumid,'3'
j=j+2
c in case region is specified adds one line type 3
if(region(1:10).ne.' '.and.reg.eq.0)then
j=j+1
reg=1
write(printout(j),'(1x,a2,a50,a3,23x,a1)')
* '* ',region(1:50),'***','3'
endif
74 read(1,'(a)',end=82, err=82)text ! reads blank lines
if(text(1:7).eq.'Sta ')then
jarr=0
goto 80 !go for arrivals
elseif(text(1:1).eq.'(')then
75 j=j+1 !This case for info between brackets after
write(printout(j),'(1x,a2,a70,a3,3x,a1)') !origin lines
* '* ',text(1:70),'***','3'
do i=2,136
if(text(i:i).eq.')')goto 74
enddo
read(1,'(a)',end=99)text
goto 75
elseif(text(1:5).eq.'Event'.or.text(1:5).eq.'EVENT')then
backspace(1) !This case for no arrivals in ims file
goto 82
endif
goto 74
c
c ARRIVALS
c
80 read(1,'(a)',end=99)text
c
c skip comments, jh may 2015
c
if(text(2:2).eq.'(') goto 80
if(text.eq.' ')then
81 read(1,'(a)',end=99)text
if(text(1:4).ne.' '.and.text(1:5).ne.'EVENT'.
* and.text(1:4).ne.'STOP'.and.text(1:5).ne.'Event')goto 85
if(text(1:4).eq.' ')goto 81
backspace(1)
if(text(1:4).eq.'STOP')kstop=1
82 continue
if(locf(1:1).eq.' ') printout(1)(45:45)=lock
write(2,'(1x,a79)')(printout(i)(2:80),i=1,j)
write(2,'(a80)')printout(1000*flines)(1:80)
if(jarr.eq.0)
* write(2,'(1x,a79)')(printout(i)(2:80),i=350*flines+1,karr)
write(2,'(a80)')' '
read(1,'(a)',end=102,err=102)text
backspace(1)
goto 60
endif
85 karr=karr+1
read(text,1140)sta,x1,x2,ph_out,fecha,tres,azph,raz,velo,
* def,snr,amp,per,am,cd,undsc,mc,mag,junk
c
c now read 6 chars of phase
c
1140 format(a5,1x,f6.2,f6.1,1x,a6,3x,a12,3f6.1,1x,f6.1, ! jh oct 08
* 8x,a3,f6.1,f10.1,f6.2,1x,2a1,a1,1x,a2,4x,f4.1,1x,a8)
if(x1.lt.dmin)dmin=x1
if(x1.gt.dmax)dmax=x1
if(mag.gt.0.0)then
j=j+1
write(printout(j)(1:80),'(1x,a1,1x,a5,1x,a2,1x,f4.2,63x,a1)')
* '$',sta,mc,mag,'3'
endif
if(cd.eq.'_')cd=' '
if(cd.ne.' ')call sei upc(cd)
read(fecha(1:12),'(2(i2,1x),f6.3)')hr,mn,sec
write(ttext(1:6),'(f6.1)')raz !approximate az residual
read(ttext(6:6),'(i1)')k
if(k.ge.5.and.raz.lt.0)raz=raz-1.0
if(k.ge.5.and.raz.gt.0)raz=raz+1.0
radius = cos(lat)**2/equrad**2
radius = (radius +sin(lat)**2/polrad**2)**(-.5)
radius = radius*x1*rad
wg=0
if(velo.gt.999.9)velo=999.9
c
c check for pdif, jh oct 08
c
if(ph_out.eq.'P DIFF') ph_out='Pdif '
if(amp.lt.1000.)then
write(printout(karr)(2:80),1120)sta,ph_out,cd,hr,mn,sec,
* amp,per,azph,velo,snr,int(raz),tres,int(radius),int(x2)
else
write(printout(karr)(2:80),1122)sta,ph_out,cd,hr,mn,sec,
* amp,per,azph,velo,snr,int(raz),tres,int(radius),int(x2)
endif
c
c now put weight oct 08 jh take it out again july 15
c
wg=0
c if(def(1:1).eq.'_') wg=4
if(ph_out(5:5).eq.' ') then
write(printout(karr)(15:15),'(i1)') wg
if(wg.eq.0) printout(karr)(15:15)=' '
else
write(printout(karr)(9:9),'(i1)') wg ! phase longer than 4 chars
if(wg.eq.0) printout(karr)(9:9)=' '
endif
1120 format(a5,4x,a6,a1,1x,2i2,1x,f5.2,5x,g7.2,1x,f4.1,f6.1,
* f5.1,f4.1,i3,f5.1,2x,i5,1x,i3,1x)
1122 format(a5,4x,a6,a1,1x,2i2,1x,f5.2,5x,g7.1,1x,f4.1,f6.1,
* f5.1,f4.1,i3,f5.1,2x,i5,1x,i3,1x)
if(text(14:18).eq.' ')printout(karr)(77:79)=' '
if(amp.eq.0.0)printout(karr)(34:45)=' '
if(azph.eq.0.0)printout(karr)(46:51)=' '
if(velo.eq.0.0)printout(karr)(52:56)=' '
if(snr.gt.99.9)write(printout(karr)(57:60),'(f4.0)')snr
if(snr.gt.999.9)printout(karr)(57:60)='999.'
if(snr.eq.0.0)printout(karr)(57:60)=' '
if(raz.eq.0.0)printout(karr)(61:63)=' '
if(raz.lt.-99.9)printout(karr)(61:63)='-99'
if(tres.lt.-99.9.or.tres.gt.999.9)
* write(printout(karr)(64:68),'(f5.0)')tres
cc if(def(1:1).eq.'_')write(printout(karr)(15:15),'(a1)')'4'
if(tres.eq.0.0.and.printout(karr)(15:15).eq.'4')
* printout(karr)(64:68)=' '
cc if(printout(karr)(15:15).eq.'0')printout(karr)(15:15)=' '
if(am.eq.'a')write(printout(karr)(16:16),'(a1)')'A'
c printout(karr)(7:8)='SZ'
if(printout(karr)(19:19).eq.' ')printout(karr)(19:19)='0'
if(printout(karr)(21:21).eq.' ')printout(karr)(21:21)='0'
if(printout(karr)(24:24).eq.' ')printout(karr)(24:24)='0'
goto 80
endif !LONG IF ends here
goto 65
c
c FORMATS !!!!!
c
100 format(1x,i4,2(1x,2i2),1x,f4.1,3a1,f7.3,f8.3,f5.1,a1,1x,a3,
* i3,f4.1,3(1x,f3.1,a1,a3),a1)
101 format(1x,i4,2(1x,2i2),1x,f4.1,3a1,f7.3,f8.3,f5.1,a1,1x,a3,
* i3,f4.1,24x,a1)
1201 format(a5,4x,a4,i1,1x,a1,1x,2i2,1x,f5.2,5x,g7.2,1x,f4.1,f6.1,
* f5.1,f4.1,i3,f5.1,2x,f5.0,1x,i3,1x)
150 format(3x,'Date',7x,'Time',8x,'Err',3x,'RMS',1x,'Latitude',1x,
* 'Longitude',2x,'Smaj',2x,'Smin',2x,'Az',1x,'Depth',3x,'Err',
* 1x,'Ndef',1x,'Nsta',1x,'Gap',
* 2x,'mdist Mdist Qual Author OrigID')
220 format('Sta',5x,'Dist EvAz',1x,
* 'Phase Time TRes Azim AzRes Slow SRes',
* ' Def SNR Amp Per Qual Magnitude ArrID')
c write IMS1.0:SHORT format, nsta, no fixing flags for origin time and location.
250 format(a22,1x,2f6.2,1x,f8.4,1x,f9.4,2f6.1,1x,
* i3,1x,f5.1,a1,f5.1,2i5,1x,i3,22x,a3,'_NDC',3x,a8)
255 format(i4,1x,4(i2,1x),f5.2,a1,2f6.2,1x,f8.4,1x,f9.4,a1,f5.1,
* f6.1,1x,i3,1x,f5.1,a1,f5.1,2i5,1x,i3,2f7.2,1x,a3,1x,a2,1x,
* a7,3x,a8)
300 format(6x,f4.1,1x,f3.1,1x,i4,1x,a3)
310 format(a2,4x,f4.1,10x,'XXX_NDC',3x,a8)
c read the IMS1.0:SHORT format, except agency and number id
c
c Finish the program
close files
c
99 continue
if(work.eq.2)then
write(2,'(a4)')'STOP'
backspace(4)
write(4,'(a4)')'STOP'
close(4)
close(7)
else
if(kstop.eq.0.and.n.gt.0)then
kstop=1
goto 82
endif
endif
102 close(1)
close(2)
write(6,*)
write(6,*)' The output file contains ',n,' events processed'
stop
end
_______________________________________________
seisan mailing list
[email protected]
http://mailman.uib.no/listinfo/seisan
