	subroutine read_template_list(fmag1,fmag2,npmin,nsmin,dep1_temp)
        include 'common_arriv.inc'
	character*80 file
	character*119 text
	character*1 cret
	cret=char(10)
cc	file='../event_dd/event.dat'
        file=file_template
        write(*,*) 'template list=',file_template
	open(7,file=file,
     1  access='direct', form='formatted',recl=120,status='unknown')
      irece=0
	nc=0
      read(7,134,rec=1) irece
 134  format(3i10,a1) 
	write(*,*) 'irece=',irece
	k=0
	do 2 irec=2,irece   !defined in common_arriv.inc
      
        read(7,1303,rec=irec) cret,iy,im,id,ih,imin,sec,t,dt,
	1 phi,dphi,ram,dram,dep,ddep,fmag,nobsp,nobss,nobsall,
     1  c_temp,c_hypo_flag,ir
 1303   format(a1,1x,5i2,f6.2,f8.2,f6.2,f8.4,f7.4,f9.4,f7.4,
	1 2f7.2,f5.2,3i4,1x,2a1,i9,f6.2)
	if(fmag.lt.fmag1.or.fmag.gt.fmag2) go to 2
	if(nobsp.lt.npmin.or.nobss.lt.nsmin) go to 2
 12       continue

	k=k+1
	phi_eva(k)=phi
	ram_eva(k)=ram
        dep_eva(k)=dep
	fmag_eva(k)=fmagj
	nobsp_eva(k)=nobsp
	nobss_eva(k)=nobss
	keq_eva(k)=ir
	iyear=iy
	 if(iy.le.1900) iyear=iy+2000
	 if(iyear.gt.2070) iyear=iyear-100


        write(text,122) iyear
 122    format('../arriv/arv_',i4.4,'.dat')
        wave_file_eva(k)=text 
cc	write(*,*) 'dir=',wave_file_eva(k)
cc	write(*,*) irec,iy,im,id,ih,imin,phi,ram,dep,fmagj
	if(k.ge.nmax_event) go to 1
 2	continue
 1	continue
	close(7)
	neq_all_ev=k
	if(neq_all_ev.ge.nmax_event) neq_all_ev=nmax_event-1
	write(*,*) 'Number of selected Template EQ=',neq_all_ev
c	write(*,'(10f8.3)') (	phi_eva(k),k=1,neq_all_ev,100)
	return
	end



      subroutine read_wave_dir(file,n_itr,phi_from,phi_to,ram_from,
     1 ram_to,dep_from,dep_to,fmag1,fmag2,npmin,nsmin,dep1_temp)
        include 'common_arriv.inc'
	include 'common_format.inc'
      character*80  text,file
	dep1_temp=0.1
      open(7,file=file)
ccc     !1 read date from 
       do k=1,30
         read(7,'(a80)') text
         if(text(1:1).ne.'#') go to 1
       enddo
 1     continue
       write(*,*) 'Number of Iteration=',text
       read(text,*) n_itr
ccc     !3 read station data file 
        do k=1,30
         read(7,'(a80)') text
         if(text(1:1).ne.'#') go to 3
       enddo
 3     continue
ccc    !4 read re-location list including template EQ. 
       do j=2,80
        if(text(j:j).eq.' ') then
          jc_pick=j-1
      stndata_file=text(1:jc_pick)
       go to 4
       endif
       enddo
 4     continue
	write(*,*) 'Station data file=',stndata_file
ccc   !4 read file name of pick list including template EQ.
      do k=1,30
         read(7,'(a80)') text
         if(text(1:1).ne.'#') go to 39
       enddo
 39    continue
cc	write(*,*) text
        do j=2,80
          if(text(j:j).eq.' ') then
          jc=j-1
       event_list=text(1:jc)
       go to 38
       endif
       enddo
 38    continue
       write(*,*) 'Re-locate event list=',event_list 
ccc    !4 read Latitude, longitude depth range for the relocation
       do k=1,30
         read(7,'(a80)') text
         if(text(1:1).ne.'#') go to 41
       enddo
 41    continue
       write(*,*) 'Lat,Lon,dep of study area ',text
       read(text,*) phi_from,phi_to,ram_from,ram_to,dep_from,dep_to       
ccc   Magnitude range for the selection of template events.
        do k=1,30
         read(7,'(a80)') text
         if(text(1:1).ne.'#') then
       read(text,*) fmag1,fmag2
       write(*,*) 'Mag. range for template selection ',fmag1,fmag2
       go to 34
       endif
       enddo
 34    continue
       



cc    read minimum number of P and S used in template events.
         do k=1,30
         read(7,'(a80)') text
         if(text(1:1).ne.'#') go to 15
       enddo
 15     continue
        write(*,*) ' Minimum number of P and S for template EQ ',text
        read(text,*) npmin,nsmin
ccc    read pick directory names for template events.
       nc=0
           do 10 k=1,300
         read(7,'(a80)',end=50) text
         if(text(1:1).eq.'#') go to 10
         if(text(1:1).eq.' ') go to 50
	 read(text,*) dep1_temp
	 go to 50
 10         continue
 50         continue
            nc_temp=nc
            close(7)

            write(*,*) 'nc_temp=',nc_temp
cc             call fusleep(1000000)
cc            call direct_cr(iy_from,iy_to,im_from,im_to)
            return
            end
	subroutine select_near_event
	include 'common_arriv.inc'
	dimension idela(100000),fmagwa(100000),iorda(100000),kkka(100000),
     1  mmma(100000),dela(1000000),kkk2a(100000)
cc	write(*,*) 'select_near_event',phi,ram,dep,nobsp,nobss
	delmax=10.0
	pideg=3.14159/180.0
	n10=neq_branch_set    !Defined in common_arriv.inc
	n20=n10*3
	   sclx=111.18*cos(phi*pideg)
	   scly=111.18
              nobspmin=nobsp
             do 55 kkmm=1,15
	     sapmax=delmax/scly
	     sarmax=delmax/sclx
	     sadmax=delmax
   
            nc=0
cc            write(*,*) 'neq_all_ev=',neq_all_ev
c	    write(*,*) kk,delmax
	   do 5 m=1,neq_all_ev
cc	      if(fmaga(m).gt.fmagmax_sel) go to 5
	      sap=abs(phi-phi_eva(m))
	      if(sap.gt.sapmax) go to 5 
	      sar=abs(ram-ram_eva(m))
	      if(sar.gt.sarmax) go to 5
	      sad=abs(dep-dep_eva(m))
	      if(sad.gt.sadmax) go to 5
cc              if(nobsp_eva(m).lt.nobspmin) go to 5
	      dy=sap*scly
	      dx=sar*sclx
	      dl=sqrt(dx*dx+dy*dy+sad*sad)
	      if(dl.gt.delmax) go to 5
	      if(dl.lt.0.001) go to 5
	      nc=nc+1
	      dela(nc)=dl
cc              dela(nc)=1000-float(nobsp_eva(m))
	      kkka(nc)=m
              if(nc.ge.100000) go to 6
 5	      continue
cc              write(*,*) 'nc=',nc,n20,nobspmin,delmax


               if(nc.gt.n20) go to 6
cc                  nobspmin=(nobspmin*3)/5
		  delmax=delmax*1.3
 55           continue
 6	      continue       
cc	      read(*,*) iok
	      if(nc.le.n20) then
		neq_branch=nc
		if(neq_branch.gt.n10) neq_branch=n10
		do k=1,neq_branch
		   meqa(k)=kkka(k)
		   enddo
		go to 88
		endif
cc	      write(*,*) 'nc=',nc
	      call small_order(nc,n20,dela,iorda)
cc              write(*,*) 'n20=',n20
	      do kk=1,n20
		 k=iorda(kk)
cc		 write(*,*) kk,dela(k),kkka(k)
		 kw=kkka(k)
		 fmaga(kk)=fmag_eva(kw)
		 kkk2a(kk)=kw
		 enddo
	      call small_order(n20,n10,fmaga,iorda)
	      	      do kk=1,n10
		 k=iorda(kk)
		 kw=kkk2a(k)
		 call condel(ram_eva(kw),phi_eva(kw),ram,phi,del)
c	write(*,122) kk,phi_eva(kw),ram_eva(kw),dep_eva(kw),
c     1 fmag_eva(kw),del,nobsp_eva(kw),nobss_eva(kw),keq_eva(kw),
c     2  wave_file_eva(kw)
		 meqa(kk)=kw
 122		 format(i5,2f8.3,f6.1,f6.2,f6.1,3i6,1x,a15)
		 enddo
		 neq_branch=n10
 88	    continue
c	   write(*,*) 'select near '
c            read(*,*) iok
	    return
	    end
          subroutine read_ok_arrival(keq)
          include 'common_arriv.inc'
          include 'common_stncod.inc'
          character*80 pick_file,file_wv
          do n=1,nstobs
             stnw(n)=''
             nstn(n)=0
             wp(n)=0.0
             ws(n)=0.0
             enddo
          pick_file=wave_file_eva(keq)
cc          write(*,*) 'read_ok_arrival=', pick_file
	  irec=keq_eva(keq)
cc	  write(*,*)  'read_ok_arrival=', irec,pick_file

       open(10,file=pick_file,
     1 access='direct',recl=7700,status='unknown') 


           read(10,rec=irec) iy,im,id,ih,imin,sec,t,dt,
     1 phi,dphi,ram,dram,dep,ddep,fmagj,sd,nobsp,nobss,
     1  nobsall,fmag,c_temp,c_hypo_flag,
     2 (stnw(k),nstn(k),po(k),wp(k),rankp(k),
     3 ipola(k),so(k),ws(k),ranks(k),(resoc(k,kps),kps=1,2),
     1  fp(k),amps(k),period(k,1),period(k,2),k=1,120)
	   if(phi_eva(keq).gt.-90.0.and.phi_eva(keq).lt.90.0) then
ccc   Store Lat and long. of the template EQ.
	phi=phi_eva(keq)
	ram=ram_eva(keq)
        dep=dep_eva(keq)
	endif
	   
c	   write(*,'(6hok_arv,i6,4f9.3,2f7.1)') irec, phi,phi_eva(keq),
c     1  ram,ram_eva(keq),dep,dep_eva(keq)

	 	   
cc	   write(*,*) 'nobsall=',nobsall
c	 write(*,*)  iy,im,id,ih,imin,sec,t,dt,
c     1 phi,dphi,ram,dram,dep,ddep,fmagj,sd,nobsp,nobss,
c     1  nobsall,fmag 
	   do k=1,nobsall
cc	      write(*,*) stnw(k),nstn(k),po(k)
	      enddo
	      


	      ner=0
	    do 29 k=1,nobsall
	       nstn(k)=0
	       do nst=1,nstobs
	       if(stnw(k).eq.stnobs(nst)) then
		  nstn(k)=nst
           call conazd(ram,phi,ramobs(nst),phiobs(nst),deltak(k),az)
		  go to 29
		  endif
		  enddo
                  wp(k)=0.0
		  ws(k)=0.0
		  ner=ner+1
 29		  continue
cc                 write(*,*) 'nstobs=',nstobs
cc		  write(*,'(10i6)') (nstn(k),k=1,nobsall)
cc		  read(*,*) iok
		  NQ=NOBSALL/2
		  if(ner.ge.5.and.ner.gt.nq) then
		     write(*,*) 'Station data Error !!!'
		     write(*,'(10a8)') (stnobs(nst),nst=1,nstobs) 
		     write(*,*) 'Observed station name'
		     write(*,'(10a8)') (stnw(k),k=1,nobsall) 
		     read(*,*) iok
		     endif
		 




          return
          end
	subroutine store_branch_arriv(kkk)
	include 'common_stncod.inc'
	include 'common_arriv.inc'
cc	write(*,'(10f8.2)')  (po(k),k=1,nobsall)
cc        write(*,*) 'store branch',kkk
 	do nst=1,nstobs
	   	wei_crossa(kkk,nst,1)=0.0
	   	wei_crossa(kkk,nst,2)=0.0
	   	wei_dd_crossa(kkk,nst,1)=0.0
	   	wei_dd_crossa(kkk,nst,2)=0.0
		po_crossa(kkk,nst)=999.9
		so_crossa(kkk,nst)=999.9
		enddo
		
	do 1 k=1,nobsall
	   nst=nstn(k)
	   if(nst.le.0) go to 1
	po_crossa(kkk,nst)=po(k)
        so_crossa(kkk,nst)=so(k)
	wei_crossa(kkk,nst,1)=wp(k)
	wei_crossa(kkk,nst,2)=ws(k)
cc	write(*,*) po(k),so(k),wp(k),ws(k),nst
 1	continue
	 phi1_crossa(kkk)=phi  !Hypo of the first event
	 ram1_crossa(kkk)=ram 
	 dep1_crossa(kkk)=dep 
	 
	return
	end
       subroutine dkwrt_hypo_dd(keq)
       include 'common_arriv.inc'
        character*80 pick_file,file_wv,text,file,file_hypo
        character*1 cret
        cret=char(10)
 
	write(file_hypo,167) iy,im
 167	format('../arriv_dd/hypo',2i2.2,'.dat')


cc        write(*,*) 'file_hypo=',file_hypo
        open(7,file=file_hypo,access='direct', form='formatted',
     1 recl=120,status='unknown')
        irece=0
cc	write(*,*) 'read file_hypo'
        read(7,134,rec=1,err=21) irece,cret
  134   format(i10,a1)  
   21   if(irece.le.1) irece=1
cc	write(*,*) 'irece=',irece
	if(irece.le.1) irece=1
	if(irece.gt.10000000) irece=2
  	irecq=irece
	irece=irece+1
	neqt=irece
	irec_hp=irece            !common_arriv
   
	if(dep.lt.-99.0) dep=-99.0
	if(dt.gt.9.9) dt=9.9
	if(dphi.gt.99.9) dphi=99.9
	if(dram.gt.99.9) dram=99.9
	if(dep.gt.999.9) dep=999.9
	if(ddep.gt.999.9) ddep=999.9
       write(7,1303,rec=irece) cret,iy,im,id,ih,imin,sec,t,dt,
	1 phi,dphi,ram,dram,dep,ddep,fmag,nobsp,nobss,nobsall,
     1  c_temp,c_hypo_flag,irec_arv,sd_all_cross
 1301   format(a1,1x,5i2,f6.2,f8.2,f6.2,f8.4,f7.4,f9.4,f7.4,
	1 2f6.2,f5.2,3i4,1x,2a1,i9,f6.2)
 1303   format(a1,1x,5i2,f6.2,f8.2,f6.2,f8.4,f7.4,f9.4,f7.4,
	1 2f7.2,f5.2,3i4,1x,2a1,i9,f6.2)
	write(7,134,rec=1) irece,cret
      close(7)
ccc     write ../arriv_dd/hypotd_all.dat  *****************
	open(39,file='../arriv_dd/hypotd_all.dat',access='direct', 
     1 form='formatted',recl=120,status='unknown')
	    read(39,134,rec=1) irecw
	irecw=irecw+1
       write(39,1303,rec=irecw) cret,iy,im,id,ih,imin,sec,t,dt,
	1 phi,dphi,ram,dram,dep,ddep,fmag,nobsp,nobss,nobsall,
     1  c_temp,c_hypo_flag,irec_arv,sd_all_cross
	write(39,134,rec=1) irecw
         close(39)



   33   continue
        return
        end
	subroutine set_arv_diff_mem(mmm)
	include 'common_stncod.inc'
	include 'common_arriv.inc'
cc        write(*,*) 'set_arv_diff_mem',nstobs,mmm
	k11=neq_branch+1 
c	do  nst=1,nstobs
c	 q1=po_crossa(k11,nst) 
c	 q2=po_crossa(mmm,nst)
c	 iw=0
c	 if(q1.lt.900.0.and.q1.gt.0.1) iw=1
c	 if(q2.lt.900.0.and.q2.gt.0.1) iw=1
c	 if(iw.eq.1)  write(*,176) stnobs(nst),po_crossa(k11,nst),
c     1 wei_dd_crossa(k11,nst,1),po_crossa(mmm,nst),
c     1 wei_dd_crossa(mmm,nst,1)
 176	 format(a7,4f8.2)
c	 enddo
cc	 read(*,*) iok
	do k=1,nstobs
	   wp(k)=0.0
	   ws(k)=0.0
	   po(k)=999.9
	   so(k)=999.9
	   nstn(k)=0
	   enddo
	   nc=0
	   nobsp=0
	   nobss=0
cc	   write(*,*) 'set_arv_diff_mem mmm=',mmm
cc	   write(*,'(10f7.2)') (wei_dd_crossa(mmm,nst,1),nst=1,nstobs)
cc	   write(*,*) 'P'
cc	   write(*,'(10f7.2)') (po_crossa(mmm,nst),nst=1,nstobs)
	do 11 nst=1,nstobs
	   iw=0
	wpq=wei_crossa(mmm,nst,1)
	if(wpq.gt.wei_crossa(k11,nst,1)) wpq=wei_crossa(k11,nst,1)
	if(wei_crossa(mmm,nst,1).lt.0.001.and.
     1  wei_crossa(k11,nst,1).lt.0.001) wpq=0.0
	wsq=wei_crossa(mmm,nst,2)
	if(wsq.gt.wei_crossa(k11,nst,2)) wsq=wei_crossa(k11,nst,2)
	if(wei_crossa(mmm,nst,2).lt.0.001.and.
     1  wei_crossa(k11,nst,2).lt.0.001) wsq=0.0

	if(wpq.gt.0.0001.or.wsq.gt.0.0001) then
	 nc=nc+1
	 stnw(nc)=stnobs(nst)
	 nstn(nc)=nst
	  po(nc)=po_crossa(k11,nst)-po_crossa(mmm,nst)
	  so(nc)=so_crossa(k11,nst)-so_crossa(mmm,nst)
	  wp(nc)=wpq
	  ws(nc)=wsq
	  nobsp=nobsp+1
	  if(ws(nc).gt.0.0001) nobss=nobss+1
	  endif
 11	 continue
	 nobsall=nc
	 do nc=1,nobsall
	  if(wp(nc).le.0.0001) po(nc)=999.9
	  if(ws(nc).le.0.0001) so(nc)=999.9	
	  enddo
cc	 read(*,*) iok
	  
	  ph=phi1_crossa(mmm)
	  ra=ram1_crossa(mmm)
	  de=dep1_crossa(mmm)
cc	  write(*,*) 'EQ=',ph,ra,de
	  do nc=1,nobsall
	     nst=nstn(nc)
	     if(nst.gt.0) then
	call conazd(ra,ph,ramobs(nst),phiobs(nst),del,az)
	heitk=altobs(nst)
cc        call  delhh(heitk,dep,del,th,tpq,dtdr,dtddel,1)
cc        call  delhh(heitk,dep,del,th,tsq,dtdr,dtddel,2)
        call  delhh(heitk,de,del,th,tpq,dtdr,dtddel,1)
        call  delhh(heitk,de,del,th,tsq,dtdr,dtddel,2)


	  trvs_cor(1,nst)=tsq
          trvp_cor(1,nst)=tpq
          deltak_cor(1,nst)=del
	  endif
c	 write(*,133) stnw(nc),nstn(nc),po(nc),wp(nc),so(nc),ws(nc),
c     1   del,tpq,tsq,wei_crossa(mmm,nst,1),wei_crossa(k11,nst,1)
 133	 format(a7,i3,' P,S=',4f7.2,' del,tp,tq=',f6.1,2f7.2,2f7.2)
	 enddo

c	 write(*,*) 'phi,ram,dep=',ph,ra,de
c	 read(*,*) iok
	 phi=phi1_crossa(k11)
	 ram=ram1_crossa(k11)
	 dep=dep1_crossa(k11)
         t=0.0

	 return
	 end
