	program pt_fl
c
c ...... sheet parsing algorithm
c
c	28 October 03 - Version to add decoding for various amplitude
c	  formats and generate he_relp and fl_relp format input files
c
	implicit none
	integer*4 i, oyr, omo, ody, ohr, omn, osc, ofs
	integer*4 lnblnk, lnb, nfic, iargc, doy
	integer*4 npar, lpar(20), phr, pmn, psc, pfs
	real*4 lat, lon, dep, mag, z_amp, n_amp, e_amp, dtt
	real*4 z_per, n_per, e_per
	character stn*6, inst*6, phase*6, ph1ch*1
	character*6 onset, comp, pol, atype
	character*256 ficarg, aline, pf_name, af_name, trf_name
	character*20 par(20)
c
	nfic=iargc()
	i=1
	call getarg(i,ficarg)
	lnb=lnblnk(ficarg)
	open(10,file=ficarg(1:lnb),status='old')
	write(*,*) ' '
	write(*,*) 'Processing: ',ficarg(1:lnb)
c
    1   read(10,'(a)',end=3) aline
	lnb = lnblnk(aline)
	write(*,*) "aline = ",aline(1:lnb)
c
	call parser(aline,npar,lpar,par)
	if(npar.eq.0) go to 1
c
c ...... decode "E" line
c
	if(par(1)(1:lpar(1)).eq.'E') then
	  lnb = lnblnk(aline)
	  write(*,*) "E-line = ",aline(1:lnb)
	  if(npar.ne.7) then
	    write(*,*) 'Invalid: ',"   ",aline(1:lnblnk(aline))
	    go to 1
	  endif
	  call d_date(par(2),lpar(2),oyr,omo,ody)
	  call d_time(par(3),lpar(3),ohr,omn,osc,ofs)
	  call d_lat(par(4),lpar(4),lat)
	  call d_lon(par(5),lpar(5),lon)
	  call d_dep(par(6),lpar(6),dep)
	  call d_mag(par(7),lpar(7),mag)
	  write(*,'(2a,3x,3i2.2,3x,3i2.2,"."i2.2,3x,f7.4,3x,f9.4,3x,
     1      f5.2,3x,f4.2)') "   ",par(1)(1:1),oyr,omo,ody,ohr,omn,
     2      osc,ofs,lat,lon,dep,mag
	  write(pf_name,'(3i2.2,".",3i2.2,".pf")')
     1      oyr,omo,ody,ohr,omn,osc
	  lnb = lnblnk(pf_name)
	  open(14,file=pf_name(1:lnb),status='unknown')
	  write(14,'(a)') "Pickfile V.2"
	  call doyc(oyr,omo,ody,doy)
c	  if(oyr.lt.10) then
	    write(14,'("T 19",i2.2,1x,i3.3,1x,i2.2,":",i2.2,":",i2.2,
     1        ".0000")') oyr,doy,ohr,omn,osc
c	  else
c	    write(14,'("T 20",i2.2,1x,i3.3,1x,i2.2,":",i2.2,":",i2.2,
c     1        ".0000")') oyr,doy,ohr,omn,osc
c	  endif
	  write(af_name,'(3i2.2,".",3i2.2,".af")')
     1      oyr,omo,ody,ohr,omn,osc
	  lnb = lnblnk(af_name)
	  open(15,file=af_name(1:lnb),status='unknown')
	  write(15,'(2a)') "# ",af_name(1:lnb-3)
	  write(15,'(a)')
     1      "# STN_NAME TYPE AMPLI PERIOD INDEX MAG"
	  write(trf_name,'(3i2.2,".",3i2.2,".trf")')
     1      oyr,omo,ody,ohr,omn,osc
	  lnb = lnblnk(trf_name)
	  open(16,file=trf_name(1:lnb),status='unknown')
	  write(16,'("T 19",i2.2,1x,i3.3,1x,i2.2,":",i2.2,":",i2.2,
     1      ".000000")') oyr,doy,ohr,omn,osc
	  write(16,'(a)') "Rotationfile V.01"
	  close(16)
	  go to 1
c
c ...... decode "C" line
c
	elseif(par(1)(1:lpar(1)).eq.'C') then
c	  call d_comm(aline)
	  go to 1
c
c ...... decode "F" line
c
	elseif(par(1)(1:lpar(1)).eq.'F') then
c	  call d_felt(aline)
	  go to 1
c
c ...... decode "P" line
c
	elseif(par(1)(1:lpar(1)).eq.'P') then
	  if(npar.ne.8) then
	    write(*,*) 'Invalid: ',"   ",aline(1:lnblnk(aline))
	    go to 1
	  endif
c
c ...... decode station and instrument
c
	  call d_a6ch(par(2),lpar(2),stn)
	  call d_a6ch(par(3),lpar(3),inst)
c
c	  if(((par(4)(1:1).eq.'P') .or.(par(4)(1:1).eq.'S')  .or.
c     1        (par(4)(1:1).eq.'-'))                          .and.
c     2       ((par(5)(1:1).eq.'Z') .or.(par(5)(1:1).eq.'N')  .or.
c     3        (par(5)(1:1).eq.'E') .or.(par(5)(1:1).eq.'-')) .and.
c     4       ((par(6)(1:1).eq.'i') .or.(par(6)(1:1).eq.'e')  .or.
c     5        (par(6)(1:1).eq.'-'))) then
c	    call d_a6ch(par(4),lpar(4),phase)
c	    call d_a6ch(par(5),lpar(5),comp)
c	    call d_a6ch(par(6),lpar(6),onset)
c	  else
c	    call d_a6ch(par(4),lpar(4),onset)
c	    call d_a6ch(par(5),lpar(5),phase)
c	    call d_a6ch(par(6),lpar(6),comp)
c	  endif
c
c ...... check for and decode various P formats---
c
c
c ...... comp, onset, phase order
c
	  if(((par(6)(1:1).eq.'P') .or.(par(6)(1:1).eq.'S')  .or.
     1        (par(6)(1:1).eq.'-'))                          .and.
     2       ((par(4)(1:1).eq.'Z') .or.(par(4)(1:1).eq.'N')  .or.
     3        (par(4)(1:1).eq.'S') .or.(par(4)(1:1).eq.'W')  .or.
     4        (par(4)(1:1).eq.'E') .or.(par(4)(1:1).eq.'-')) .and.
     5       ((par(5)(1:1).eq.'i') .or.(par(5)(1:1).eq.'e')  .or.
     6        (par(5)(1:1).eq.'-'))) then
	    call d_a6ch(par(4),lpar(4),comp)
	    call d_a6ch(par(5),lpar(5),onset)
	    call d_a6ch(par(6),lpar(6),phase)
c
c ...... phase, comp, onset order
c
	  elseif(((par(4)(1:1).eq.'P') .or.(par(4)(1:1).eq.'S')  .or.
     1        (par(4)(1:1).eq.'-'))                          .and.
     2       ((par(5)(1:1).eq.'Z') .or.(par(5)(1:1).eq.'N')  .or.
     3        (par(5)(1:1).eq.'S') .or.(par(5)(1:1).eq.'W')  .or.
     4        (par(5)(1:1).eq.'E') .or.(par(5)(1:1).eq.'-')) .and.
     5       ((par(6)(1:1).eq.'i') .or.(par(6)(1:1).eq.'e')  .or.
     6        (par(6)(1:1).eq.'-'))) then
	    call d_a6ch(par(4),lpar(4),phase)
	    call d_a6ch(par(5),lpar(5),comp)
	    call d_a6ch(par(6),lpar(6),onset)
c
c ...... onset, phase, comp order
c
	  elseif(((par(5)(1:1).eq.'P') .or.(par(5)(1:1).eq.'S')  .or.
     1        (par(5)(1:1).eq.'-'))                          .and.
     2       ((par(6)(1:1).eq.'Z') .or.(par(6)(1:1).eq.'N')  .or.
     3        (par(6)(1:1).eq.'S') .or.(par(6)(1:1).eq.'W')  .or.
     4        (par(6)(1:1).eq.'E') .or.(par(6)(1:1).eq.'-')) .and.
     5       ((par(4)(1:1).eq.'i') .or.(par(4)(1:1).eq.'e')  .or.
     6        (par(4)(1:1).eq.'-'))) then
	    call d_a6ch(par(4),lpar(4),onset)
	    call d_a6ch(par(5),lpar(5),phase)
	    call d_a6ch(par(6),lpar(6),comp)
c
c ...... indecipherable comp, onset, phase order
c
	  else
	    write(*,*) 
     1        "WARNING: indecipherable comp, onset, phase order"
	    go to 1
	  endif
	  if(lpar(7).gt.4) then
	    call d_a6ch(par(8),lpar(8),pol)
	    call d_time(par(7),lpar(7),phr,pmn,psc,pfs)
	  else
	    call d_a6ch(par(7),lpar(7),pol)
	    call d_time(par(8),lpar(8),phr,pmn,psc,pfs)
	  endif
	  write(*,'("   P   ",a6,3x,a6,3x,a6,3x,a6,3x,a6,3x,a6,
     1      3x,3i2.2,".",i2.2,3x,a6)') 
     2      stn,inst,onset,phase,comp,pol,phr,pmn,psc,pfs
	  call dtcalc(oyr,doy,ohr,omn,osc,ofs,phr,pmn,psc,pfs,dtt)
	  call psget(phase,ph1ch)
	  write(*,'(2a," ",a1)') 'phase & ph1ch = ',
     1      phase(1:lnblnk(phase)),ph1ch
	  if(ph1ch.ne.'-') then
	    write(14,'(1x,a4,1x,a4,"  1111 "a1,1x,a1,2x,f8.4,
     1        " ? 0.1000 19",i2.2,1x,i3.3,1x,i2.2,":",i2.2,":",
     2        i2.2,".",i2.2,"0000")')
     3        stn,inst,onset,ph1ch,dtt,oyr,doy,phr,pmn,psc,pfs
	  endif
	  go to 1
c
c ...... decode "A" or "S" line
c
	elseif((par(1)(1:lpar(1)).eq.'A').or.
     1         (par(1)(1:lpar(1)).eq.'S')) then
	  if(npar.ne.6) then
	    write(*,*) 'Invalid: ',"   ",aline(1:lnblnk(aline))
	    go to 1
	  endif
	  call d_a6ch(par(2),lpar(2),stn)
	  call d_a6ch(par(3),lpar(3),atype)
	  if(par(1)(1:lpar(1)).eq.'S') atype='100X  '
c
c ...... decode different amplitude formats
c
	  if( par(4)(1:lpar(4)) .eq. '-' ) then
	    call d_amp(par(4),lpar(4),z_amp)
	    call d_amp(par(5),lpar(5),n_amp)
	    call d_amp(par(6),lpar(6),e_amp)
	    write(*,'("   A   ",a6,3x,a6,3x,f6.2,3x,f6.2,3x,f6.2)')
     1        stn,atype,z_amp,n_amp,e_amp
	    if(atype(1:2).eq.'WA') then
	      if(n_amp.gt.0.0) then
	        write(15,'(1x,a3,a3,1x,a3,1x,f6.2,
     1            " 0.800 111 -1.000")')
     2            stn(1:lpar(2)),'BHN',atype(1:lpar(3)),n_amp
	      endif
	      if(e_amp.gt.0.0) then
	        write(15,'(1x,a3,a3,1x,a3,1x,f6.2,
     1            " 0.800 111 -1.000")')
     2            stn(1:lpar(2)),'BHE',atype(1:lpar(3)),e_amp
	      endif
	    endif
	  elseif( par(4)(1:lpar(4)) .eq. 'N' ) then
	    call d_amp(par(5),lpar(5),n_amp)
	    if(atype(1:2).eq.'WA') then
	      if(n_amp.gt.0.0) then
	        write(15,'(1x,a3,a3,1x,a3,1x,f6.2,
     1            " 0.800 111 -1.000")')
     2            stn(1:lpar(2)),'BHN',atype(1:lpar(3)),n_amp
	      endif
	    endif
	  elseif( par(4)(1:lpar(4)) .eq. 'E' ) then
	    call d_amp(par(6),lpar(6),e_amp)
	    if(atype(1:2).eq.'WA') then
	      if(e_amp.gt.0.0) then
	        write(15,'(1x,a3,a3,1x,a3,1x,f6.2,
     1            " 0.800 111 -1.000")')
     2            stn(1:lpar(2)),'BHE',atype(1:lpar(3)),e_amp
	      endif
	    endif
	  endif
	  write(*,'("   A   ",a6,3x,a6,3x,f6.2,3x,f6.2,3x,f6.2)')
     1      stn,atype,z_amp,n_amp,e_amp
	  if(atype(1:2).eq.'WA') then
	    if(n_amp.gt.0.0) then
	      write(15,'(1x,a3,a3,1x,a3,1x,f6.2,
     1          " 0.800 111 -1.000")')
     2          stn(1:lpar(2)),'BHN',atype(1:lpar(3)),n_amp
	    endif
	    if(e_amp.gt.0.0) then
	      write(15,'(1x,a3,a3,1x,a3,1x,f6.2,
     1          " 0.800 111 -1.000")')
     2          stn(1:lpar(2)),'BHE',atype(1:lpar(3)),e_amp
	    endif
	  endif
	  go to 1
c
c ...... decode "B" line
c
	elseif(par(1)(1:lpar(1)).eq.'B') then
	  if(npar.ne.7) then
	    write(*,*) 'Invalid: ',"   ",aline(1:lnblnk(aline))
	    go to 1
	  endif
	  call d_a6ch(par(2),lpar(2),stn)
	  call d_a6ch(par(3),lpar(3),atype)
	  call d_amp(par(5),lpar(5),z_amp)
	  call d_amp(par(6),lpar(6),n_amp)
	  call d_amp(par(7),lpar(7),e_amp)
	  write(*,'("   A   ",a6,3x,a6,3x,f6.2,3x,f6.2,3x,f6.2)')
     1      stn,atype,z_amp,n_amp,e_amp
	  go to 1
c
c ...... decode "D" line
c
	elseif(par(1)(1:lpar(1)).eq.'D') then
	  if(npar.ne.9) then
	    write(*,*) 'Invalid: ',"   ",aline(1:lnblnk(aline))
	    go to 1
	  endif
	  call d_a6ch(par(2),lpar(2),stn)
	  call d_a6ch(par(3),lpar(3),atype)
	  call d_per(par(4),lpar(4),z_per)
	  call d_amp(par(5),lpar(5),z_amp)
	  call d_per(par(6),lpar(6),n_per)
	  call d_amp(par(7),lpar(6),n_amp)
	  call d_per(par(8),lpar(8),e_per)
	  call d_amp(par(9),lpar(7),e_amp)
	  write(*,'("   D   ",a6,3x,a6,6(3x,f6.2))')
     1      stn,atype,z_per,z_amp,n_per,n_amp,e_per,e_amp
	  go to 1
c
c ...... decode "X" line
c
	elseif(par(1)(1:lpar(1)).eq.'X') then
	  write(*,*) 'Finished: ',ficarg(1:lnblnk(ficarg))
	else
	  write(*,*) 'Invalid line code:   ',aline(1:lnblnk(aline))
	  go to 1
	endif
c
    3   close(10)
c
	stop
	end

	subroutine dtcalc(oyr,doy,ohr,omn,osc,ofs,
     1    phr,pmn,psc,pfs,dtt)
c
c ...... calculate time difference
c
	implicit none
	integer*4 oyr, doy, ohr, omn, osc, ofs, phr, pmn, psc, pfs
	integer*4 lnb, lnblnk, iss, system, ipid, getpid
	real*4 dtt, mtt
	character*256 aline, bline, cline
c
	ipid = getpid()
c
	write(*,'(a,i5.5)') "ipid = ",ipid
	write(aline,'("caldate -f %M:%S.%F -d 19",
     2    i2.2,".",i3.3,","i2.2,":",i2.2,":",i2.2,
     3    ".",i2.2," 19",i2.2,".",i3.3,","i2.2,":",i2.2,":",i2.2,
     4    ".",i2.2," > /tmp/p_test.P.",i5.5)')
     5    oyr,doy,phr,pmn,psc,pfs,oyr,doy,ohr,omn,osc,ofs,ipid
	lnb = lnblnk(aline)
	write(*,'(2a)') 'aline = ',aline(1:lnb)
	iss = system(aline(1:lnb))
	write(bline,'(a,i5.5)') "/tmp/p_test.P.",ipid
	lnb = lnblnk(bline)
	write(*,'(2a)') "bline = ",bline(1:lnb)
	open(9,file=bline(1:lnb),status='old')
	read(9,'(a)') cline
	lnb = lnblnk(cline)
	write(*,*) "cline = ",cline(1:lnb)
	if( cline(1:1) .eq. "-" ) then
	  read(cline(2:lnb),'(f2.0,1x,f7.4)') mtt,dtt
	  dtt = -60.*mtt - dtt
	  if(dtt.lt.0.) dtt = dtt + 60.
	else
	  read(cline(1:lnb),'(f2.0,1x,f7.4)') mtt,dtt
	  dtt = 60.*mtt + dtt
	endif
	write(*,'(a,f10.4)') "dtt = ",dtt
	close(9,status='delete')
c
	return
	end

	subroutine psget(phase,ph1ch)
c
c ...... extract phase type
c
	implicit none
	integer*4 i, lnb, lnblnk
	character*6 phase
	character*1 ph1ch
c
	lnb = lnblnk(phase)
	write(*,*) 'psget - phase = ',phase(1:lnb)
	if((lnb.eq.1).and.(phase(1:1).eq.'-')) then
	  ph1ch = '-'
	  go to 2
	endif
	i = 0
    1   i = i + 1
	if(i.gt.lnb) then
	  ph1ch = '-'
	  go to 2
	endif
	if(phase(i:i).eq.'P') then
	  ph1ch = 'P'
	  go to 2
	elseif(phase(i:i).eq.'S') then
	  ph1ch = 'S'
	  go to 2
	endif
	go to 1
    2   continue
c
	return
	end

	subroutine doyc(yr,mo,dy,doy)
c
c ...... calculate doy during 20th century
c
	implicit none
	integer*4 yr, mo, dy, doy
	integer*4 msnly(12), msly(12), ily
c
	data msnly /1,32,60,91,121,152,182,213,244,274,305,335/
	data msly  /1,32,61,92,122,153,183,214,245,275,306,336/
c
	ily = yr - 4*(yr/4)
	if(ily.eq.0) then
	  doy = msly(mo) + dy - 1
	else
	  doy = msnly(mo) + dy - 1
	endif
c
	return
	end

	subroutine parser(aline,npar,lpar,par)
c
c ...... parse aline
c
	implicit none
	integer*4 i, j, lnb, lnblnk, itb(20), ite(20)
	integer*4 npar, lpar(20)
	character*256 aline
	character*20 par(20)
	character*1 tab, blank, quotes
c
	data tab,blank,quotes /Z'09',' ','"'/
c
	do 10 i=1,20
	  par(i)='                    '
	  lpar(i)=0
   10   continue
	lnb=lnblnk(aline)
	npar=0
	j=0
    1   j=j+1
	if(j.gt.lnb) go to 4
	if((aline(j:j).eq.tab).or.(aline(j:j).eq.blank)) go to 1
	npar=npar+1
	itb(npar)=j
	if(aline(j:j).eq.quotes) then
    2     j=j+1
	  if(aline(j:j).ne.quotes) go to 2
	  ite(npar)=j
	  go to 1
	endif
    3   j=j+1
	if(j.gt.lnb) then
	  ite(npar)=j-1
	  go to 4
	endif
	if((aline(j:j).ne.tab).and.(aline(j:j).ne.blank)) go to 3
	ite(npar)=j-1
	go to 1
    4   continue
	do 5 i=1,npar
	  read(aline(itb(i):ite(i)),'(a)') par(i)
	  lpar(i)=lnblnk(par(i))
    5   continue
c
c	write(*,*) 'subroutine parser:'
c	write(*,'(a,i2)') 'npar = ',npar
c	do 6 i=1,npar
c	  write(*,'(a,i2,a,i2,a,a)') 
c     1      'par(',i,')(1:',lpar(i),') = ',par(i)(1:lpar(i))
c    6   continue
c
	end

	subroutine d_date(par,lpar,yr,mo,dy)
c
c ..... decode date
c
	implicit none
	integer*4 yr, mo, dy, lpar
	character*20 par
c
	write(*,*) 'd_date = ',par(1:lpar)
	if(lpar.eq.6) then
	  read(par(1:lpar),'(3i2)',err=2) mo, dy, yr
	  if((mo.eq.0).or.(mo.gt.12)) then
	    read(par(1:lpar),'(3i2)',err=2) yr, mo, dy
	  endif
	else
	  write(*,*) 'Invalid date: ',par(1:lpar)
	endif
	return
    2   mo=99
	dy=99
	yr=99
	write(*,*) 'Invalid date: ',par(1:lpar)
c
	return
	end

	subroutine d_time(par,lpar,hr,mn,sc,fs)
c
c ...... decode origin time
c
	implicit none
	integer*4 hr, mn, sc, fs, lpar
	character*20 par
c
	write(*,*) 'd_time = ',par(1:lpar)
	if(lpar.eq.4) then
	  read(par(1:4),'(2i2)',err=2) hr, mn
	  sc=0
	  fs=0
	elseif(lpar.eq.6) then
	  read(par(1:6),'(3i2)',err=2) hr, mn, sc
	  fs=0
	elseif((lpar.eq.7).and.(par(7:7).eq.'.')) then
	  read(par(1:6),'(3i2)',err=2) hr, mn, sc
	  fs=0
	elseif((lpar.eq.8).and.(par(7:7).eq.'.')) then
	  read(par(1:8),'(3i2,1x,i1)',err=2) hr, mn, sc, fs
	  fs=10*fs
	elseif((lpar.eq.9).and.(par(7:7).eq.'.')) then
	  read(par(1:9),'(3i2,1x,i2)',err=2) hr, mn, sc, fs
	else
	  write(*,*) 'Invalid time: ',par(1:lpar)
	endif
	return
    2   hr=99
	mn=99
	sc=99
	fs=99
	write(*,*) 'Invalid time: ',par(1:lpar)
c
	return
	end

	subroutine d_lat(par,lpar,lat)
c
c ...... decode latitude
c
	implicit none
	integer*4 i, latd, latm, latfm, lpar, nfm
	integer*4 dpos, ppos, dpc, ppc
	real*4 lat
	character*20 par
c
	dpos=0
	ppos=0
	dpc=0
	ppc=0
	do 1 i=1,lpar
	  if(par(i:i).eq.'-') then
	    dpos=i
	    dpc=dpc+1
	  elseif(par(i:i).eq.'.') then
	    ppos=i
	    ppc=ppc+1
	  endif
    1   continue
c	write(*,*) 'dpos & ppos = ',dpos,ppos
c	write(*,*) 'dpc & ppc = ',dpc,ppc
c	write(*,*) 'd_lat: lat = ',par(1:lpar)
	if((dpc.gt.1).or.(ppc.gt.1)) then
	  write(*,*) 'Invalid latitude: ',par(1:lpar)
	  lat=38.0
	  return
	endif
	if(par(1:1).eq.'-') then
	  lat=38.0
	  return
	endif
	if((dpc.eq.0).and.(ppc.eq.0)) then
	  read(par(1:lpar),'(i)',err=2) latd
	  lat=real(latd)
	elseif((dpc.eq.0).and.(ppc.eq.1)) then
	  read(par(1:lpar),'(f)',err=2) lat
	elseif((dpc.eq.1).and.(ppc.eq.0)) then
	  read(par(1:dpos-1),'(i)',err=2) latd
	  read(par(dpos+1:lpar),'(i)',err=2) latm
	  lat=real(latd)+real(latm)/60.
	else
	  read(par(1:dpos-1),'(i)',err=2) latd
	  read(par(dpos+1:ppos-1),'(i)',err=2) latm
	  nfm=lpar-ppos
	  if(nfm.eq.0) then
	    lat=real(latd)+real(latm)/60.
	  elseif(nfm.eq.1) then
	    read(par(ppos+1:lpar),'(i)',err=2) latfm
	    lat=real(latd)+real(latm)/60.+real(latfm)/600.
	  elseif(nfm.eq.2) then
	    read(par(ppos+1:lpar),'(i)',err=2) latfm
	    lat=real(latd)+real(latm)/60.+real(latfm)/6000.
	  endif
	endif
	return
    2   lat=38.0
	write(*,*) 'Invalid latitude: ',par(1:lpar)
c
	return
	end

	subroutine d_lon(par,lpar,lon)
c
c ...... decode longitude
c
	implicit none
	integer*4 i, lond, lonm, lonfm, lpar
	integer*4 dpos, ppos, dpc, ppc, nfm
	real*4 lon
	character*20 par
c
	dpos=0
	ppos=0
	dpc=0
	ppc=0
	do 1 i=1,lpar
	  if(par(i:i).eq.'-') then
	    dpos=i
	    dpc=dpc+1
	  elseif(par(i:i).eq.'.') then
	    ppos=i
	    ppc=ppc+1
	  endif
    1   continue
	if(par(1:1).eq.'-') then
	  lon=-122.0
	  return
	endif
	if((dpc.gt.1).or.(ppc.gt.1)) then
	  write(*,*) 'Invalid longitude: ',par(1:lpar)
	  lon=-122.0
	  return
	endif
	if((dpc.eq.0).and.(ppc.eq.0)) then
	  read(par(1:lpar),'(i)',err=2) lond
	  lon=real(lond)
	elseif((dpc.eq.0).and.(ppc.ge.1)) then
	  read(par(1:lpar),'(f)',err=2) lon
	elseif((dpc.ge.1).and.(ppc.eq.0)) then
	  read(par(1:dpos-1),'(i)',err=2) lond
	  read(par(dpos+1:lpar),'(i)',err=2) lonm
	  lon=real(lond)+real(lonm)/60.
	else
	  read(par(1:dpos-1),'(i)',err=2) lond
	  read(par(dpos+1:ppos-1),'(i)',err=2) lonm
	  nfm=lpar-ppos
	  if(nfm.eq.0) then
	    lon=real(lond)+real(lonm)/60.
	  elseif(nfm.eq.1) then
	    read(par(ppos+1:lpar),'(i)',err=2) lonfm
	    lon=real(lond)+real(lonm)/60.+real(lonfm)/600.
	  elseif(nfm.eq.2) then
	    read(par(ppos+1:lpar),'(i)',err=2) lonfm
	    lon=real(lond)+real(lonm)/60.+real(lonfm)/6000.
	  endif
	endif
c
	lon=-lon
	return
    2   lon=-122.0
	write(*,*) 'Invalid longitude: ',par(1:lpar)
c
	return
	end

	subroutine d_dep(par,lpar,dep)
c
c ...... decode depth
c
	implicit none
	integer*4 i, depkm, lpar, ichar
	integer*4 dpos, ppos, dpc, ppc, ich
	real*4 dep
	character*20 par
c
	dpos=0
	ppos=0
	dpc=0
	ppc=0
	do 1 i=1,lpar
	  if(par(i:i).eq.'-') then
	    dpos=i
	    dpc=dpc+1
	    dep=8.0
	    return
	  elseif(par(i:i).eq.'.') then
	    ppos=i
	    ppc=ppc+1
	  endif
    1   continue
c
	call numb(par,lpar)
	if(lpar.eq.0) then
	  dep=0.0
	  return
	endif
c
	if(lpar.eq.1) then
	  ich=ichar(par(1:1))
	  if((ich.lt.48).or.(ich.gt.57)) then
	    dep=8.0
	  else
	    read(par(1:1),'(i)',err=2) depkm
	    dep=real(depkm)
	  endif
	  return
	else
	  if(ppc.gt.0) then
	    read(par(1:lpar),'(f)',err=2) dep
	  else
	    read(par(1:lpar),'(i)',err=2) depkm
	    dep=real(depkm)
	  endif
	endif
	return
    2   dep=8.0
	write(*,*) 'Invalid depth: ',par(1:lpar)
c
	return
	end

	subroutine d_mag(par,lpar,mag)
c
c ...... decode magnitude
c
	implicit none
	integer*4 i, magi, lpar, ichar
	integer*4 dpos, ppos, dpc, ppc, ich
	real*4 mag
	character*20 par
c
	dpos=0
	ppos=0
	dpc=0
	ppc=0
	do 1 i=1,lpar
	  if(par(i:i).eq.'-') then
	    dpos=i
	    dpc=dpc+1
	    mag=0.0
	    return
	  elseif(par(i:i).eq.'.') then
	    ppos=i
	    ppc=ppc+1
	  endif
    1   continue
c
	call numb(par,lpar)
	if(lpar.eq.0) then
	  mag=0.0
	  return
	endif
c
	if(lpar.eq.1) then
	  ich=ichar(par(1:1))
	  if((ich.lt.48).or.(ich.gt.57)) then
	    mag=0.0
	  else
	    read(par(1:1),'(i)',err=2) magi
	    mag=real(magi)
	  endif
	  return
	else
	  if(ppc.gt.0) then
	    read(par(1:lpar),'(f)',err=2) mag
	  else
	    read(par(1:lpar),'(i)',err=2) magi
	    mag=real(magi)
	  endif
	endif
	return
    2   mag=0.0
	write(*,*) 'Invalid magnitude: ',par(1:lpar)
c
	return
	end

	subroutine d_a6ch(par,lpar,a6ch)
c
c ...... decode a6 code
c
	implicit none
	integer*4 lpar
	character*6 a6ch
	character*20 par
c
	read(par(1:lpar),'(a)') a6ch
c
	return
	end

	subroutine d_amp(t_par,t_lpar,amp)
c
c ...... decode phase amplitude
c
	implicit none
	integer*4 i, lpar, ampi, t_lpar
	integer*4 dpos, ppos, dpc, ppc
	real*4 amp
	character*20 par, t_par
c
	par = t_par(1:t_lpar)
	lpar = t_lpar
c
	dpos=0
	ppos=0
	dpc=0
	ppc=0
c
c ...... remove "<" and ">" signs
c
	if( ( t_par(1:1) .eq. ">" ) .or. ( t_par(1:1) .eq. "<" ) ) then
	  par = t_par(2:t_lpar)
	  lpar = t_lpar - 1
	endif
c
	do 1 i=1,lpar
	  if(par(i:i).eq.'-') then
	    dpos=i
	    dpc=dpc+1
	    amp=0.0
	    return
	  elseif(par(i:i).eq.'.') then
	    ppos=i
	    ppc=ppc+1
	  endif
    1   continue
c
	call numb(par,lpar)
	if(lpar.eq.0) then
	  amp=0.0
	  return
	endif
c
	if(dpc.gt.0) then
	  amp=0.0
	  return
	elseif(ppc.gt.0) then
	  read(par(1:lpar),'(f)',err=2) amp
	else
	  read(par(1:lpar),'(i)',err=2) ampi
	  amp=real(ampi)
	endif
	return
    2   amp=0.0
	write(*,*) 'Invalid amplitude: ',par(1:lpar)
c
	return
	end

	subroutine d_per(par,lpar,per)
c
c ...... decode phase period
c
	implicit none
	integer*4 i, lpar, peri
	integer*4 dpos, ppos, dpc, ppc
	real*4 per
	character*20 par
c
	dpos=0
	ppos=0
	dpc=0
	ppc=0
	do 1 i=1,lpar
	  if(par(i:i).eq.'-') then
	    dpos=i
	    dpc=dpc+1
	    per=0.0
	    return
	  elseif(par(i:i).eq.'.') then
	    ppos=i
	    ppc=ppc+1
	  endif
    1   continue
c
	call numb(par,lpar)
	if(lpar.eq.0) then
	  per=0.0
	  return
	endif
c
	if(dpc.gt.0) then
	  per=0.0
	  return
	elseif(ppc.gt.0) then
	  read(par(1:lpar),'(f)',err=2) per
	else
	  read(par(1:lpar),'(i)',err=2) peri
	  per=real(peri)
	endif
	return
    2   per=0.0
	write(*,*) 'Invalid period: ',par(1:lpar)
c
	return
	end

	subroutine numb(par,lpar)
c
c ...... remove non-numeric characters
c
	implicit none
	integer*4 i, j, lpar, ich
	character*20 par
	character*1 tpar(20)
c
	j=0
	do 1 i=1,lpar
	  ich=ichar(par(i:i))
	  if((ich.eq.46).or.((ich.ge.48).and.(ich.le.57))) then
	    j=j+1
	    tpar(j)=par(i:i)
	  endif
    1   continue
	lpar=j
	par='                    '
	if(lpar.eq.1) then
	  par=tpar(1)
	elseif(lpar.eq.2) then
	  par=tpar(1)//tpar(2)
	elseif(lpar.eq.3) then
	  par=tpar(1)//tpar(2)//tpar(3)
	elseif(lpar.eq.4) then
	  par=tpar(1)//tpar(2)//tpar(3)//tpar(4)
	elseif(lpar.eq.5) then
	  par=tpar(1)//tpar(2)//tpar(3)//tpar(4)//tpar(5)
	elseif(lpar.eq.6) then
	  par=tpar(1)//tpar(2)//tpar(3)//tpar(4)//tpar(5)//tpar(6)
	elseif(lpar.eq.7) then
	  par=tpar(1)//tpar(2)//tpar(3)//tpar(4)//tpar(5)//tpar(6)
     1    //tpar(7)
	elseif(lpar.eq.8) then
	  par=tpar(1)//tpar(2)//tpar(3)//tpar(4)//tpar(5)//tpar(6)
     1    //tpar(7)//tpar(8)
	elseif(lpar.eq.9) then
	  par=tpar(1)//tpar(2)//tpar(3)//tpar(4)//tpar(5)//tpar(6)
     1    //tpar(7)//tpar(8)//tpar(9)
	endif
c
	return
	end
