      program psmove
c
c  *************************************************************************
c
      parameter(MAXPOINTS=16388, MAXPOINTS2=MAXPOINTS*2)
      dimension d2(MAXPOINTS),caz(3),ampud(23),ampew(23),ampsn(23)
      character eqfile*64,outfil*64,comp(3,2)*6,outc(2)*5,knm(2)*8
      complex data(MAXPOINTS,3),zero1
      double precision gnorm
      logical yes,yesno,rel
      integer blank,ounit
c **********************************************************************
c
c common block info for link with subroutine sacio
c
c   
c scaio is in Tom Owens' SAC input/output routines in Subs library
	
      real instr
      integer year,jday,hour,min,isec,msec
      character*8 sta,cmpnm,evnm
      character  idcode*2,staname*4,clenth*8,cpname*1
      common /tjocm/ dmin,dmax,dmean,year,jday,hour,min,isec,msec,sta,
     *            cmpnm,az,cinc,evnm,baz,delta,rayp,depth,decon,agauss,
     *              c,tq,instr,dlen,begin,t0,t1,t2
c
c **************************************************************************
c
c   parameter definitions may be found in sacio comments
c
      common /win/ data
      common /innout/ inunit,ounit
      inunit=5
      ounit=6
      zero1=cmplx(0.,0.)
      pi=3.141592654
      call iniocm
      call asktxt('Specify SAC file: ',eqfile)
      call asktxt('Specify output file: ',outfil)
    
      call sacio(eqfile,d2(1),npts,dt,1)
      write(*,*)delta,slowness
      call compslow(delta,slowness)

      itype=2
      write(*,*)delta,slowness
      call psmoutt(d2,npts,begin,dt,slowness,Itype)
      call sacio(outfil,d2(1),npts,dt,-1)
      end


      subroutine compslow(delta,slow)
      
        dimension x(161),y(161)
        data x/
     #  10.5, 11.0, 11.5, 12.0, 12.5, 13.0, 13.5, 14.0, 14.5, 15.0,
     #  15.5, 16.0, 16.5, 17.0, 17.5, 18.0, 18.5, 19.0, 19.5, 20.0,
     #  20.5, 21.0, 21.5, 22.0, 22.5, 23.0, 23.5, 24.0, 24.5, 25.0,
     #  25.5, 26.0, 26.5, 27.0, 27.5, 28.0, 28.5, 29.0, 29.5, 30.0,
     #  30.5, 31.0, 31.5, 32.0, 32.5, 33.0, 33.5, 34.0, 34.5, 35.0,
     #  35.5, 36.0, 36.5, 37.0, 37.5, 38.0, 38.5, 39.0, 39.5, 40.0,
     #  40.5, 41.0, 41.5, 42.0, 42.5, 43.0, 43.5, 44.0, 44.5, 45.0,
     #  45.5, 46.0, 46.5, 47.0, 47.5, 48.0, 48.5, 49.0, 49.5, 50.0,
     #  50.5, 51.0, 51.5, 52.0, 52.5, 53.0, 53.5, 54.0, 54.5, 55.0,
     #  55.5, 56.0, 56.5, 57.0, 57.5, 58.0, 58.5, 59.0, 59.5, 60.0,
     #  60.5, 61.0, 61.5, 62.0, 62.5, 63.0, 63.5, 64.0, 64.5, 65.0,
     #  65.5, 66.0, 66.5, 67.0, 67.5, 68.0, 68.5, 69.0, 69.5, 70.0,
     #  70.5, 71.0, 71.5, 72.0, 72.5, 73.0, 73.5, 74.0, 74.5, 75.0,
     #  75.5, 76.0, 76.5, 77.0, 77.5, 78.0, 78.5, 79.0, 79.5, 80.0,
     #  80.5, 81.0, 81.5, 82.0, 82.5, 83.0, 83.5, 84.0, 84.5, 85.0,
     #  85.5, 86.0, 86.5, 87.0, 87.5, 88.0, 88.5, 89.0, 89.5, 90.0,
     # 120.0/

        data y/
     #  13.56,13.55,13.53,13.51,13.49,13.47,13.42,13.36,13.29,13.19,
     #  13.08,12.94,12.79,12.63,12.44,12.23,12.00,11.77,11.53,11.29,
     #  11.05,10.81,10.57,10.36,10.16, 9.97, 9.79, 9.63, 9.48, 9.34,
     #   9.24, 9.15, 9.07, 9.01, 8.97, 8.94, 8.92, 8.91, 8.90, 8.89,
     #   8.87, 8.84, 8.82, 8.79, 8.77, 8.74, 8.71, 8.69, 8.66, 8.63,
     #   8.60, 8.57, 8.54, 8.51, 8.47, 8.44, 8.40, 8.37, 8.34, 8.30,
     #   8.27, 8.24, 8.20, 8.16, 8.13, 8.09, 8.06, 8.02, 7.99, 7.96, 
     #   7.92, 7.88, 7.84, 7.81, 7.77, 7.73, 7.69, 7.65, 7.62, 7.58,
     #   7.54, 7.51, 7.47, 7.43, 7.40, 7.37, 7.33, 7.30, 7.26, 7.22,
     #   7.19, 7.15, 7.11, 7.07, 7.04, 7.00, 6.97, 6.93, 6.90, 6.86,
     #   6.83, 6.80, 6.76, 6.73, 6.70, 6.67, 6.64, 6.60, 6.57, 6.53,
     #   6.50, 6.47, 6.43, 6.40, 6.37, 6.33, 6.30, 6.26, 6.22, 6.19,
     #   6.14, 6.10, 6.05, 6.01, 5.97, 5.93, 5.89, 5.85, 5.82, 5.79,
     #   5.75, 5.72, 5.68, 5.64, 5.60, 5.56, 5.52, 5.48, 5.44, 5.40,
     #   5.36, 5.32, 5.29, 5.25, 5.21, 5.16, 5.11, 5.06, 5.02, 4.97,
     #   4.94, 4.90, 4.87, 4.84, 4.81, 4.78, 4.76, 4.74, 4.72, 4.70,
     #   4.44/
      if(delta.lt.x(1))then
      slow=y(1)-(y(2)-y(1))/(x(2)-x(1))*(x(1)-delta)
      end if
      if(delta.gt.x(161))then
      slow=y(161)+(y(161)-y(160))/(x(161)-x(160))*(delta-x(161))
      end if

      do 100 i=2,161
      if(delta.gt.x(i-1).and.delta.le.x(i))then
      slow=y(i-1)+(y(i)-y(i-1))/(x(i)-x(i-1))*(delta-x(i-1))
      end if
100   continue
      return
      end
       


C  psmove.f
C
C  The program makes moveout corrections to Ps delay times relative to P
C  onset for traces with different slownesses. It can also correct the
C  moveout for other 3 multiple phases optionally, they are Ppps, Ppss
C  and Psss.
C  Reference slowness is 6.4 s/deg.
C  It is assumed that Ps and the other multiples have the same slowness
C  with the corresponding P phase which may have big deviations for 
C  multiples at large depth.
C  It uses Earth-Flattening-Approximation.
C
C  Input data are ASCII written from SeismicHandler with the header: 
C  SLOWNESS" (TMP_PSMOUT.ASC)
C
C  Model: ./iasp91.dat
C
C  Output: binary file of SeismicHandler.
C  (PSMOUT.QBN, PPPSMOUT, PPSSMOUT, PSSSMOUT)
C
C  Xiaohui Yuan, Sep. 1997.
C
C
        subroutine psmoutt(x,npt,tbeg,delt,slowness,itype)
	dimension ttmo(100,200),tt(200),maxt(100),maxy(2000)
        dimension x(5000),y(5000),ysum(5000),tref(5000)
	character name*20,ch*10
	common /slow/ slow1,slow2,dslow
	common /time/ time1,time2,dtime

c
c  i/o channels
c
	in=31
	out=32
c
c  open input and output data file and read some values
c
c        open(in,file='TMP_PSMOUT.ASC',status='old')
c        read(in,'(a)') name
c        read(in,*) ntrace,tbeg,tend,delt,itype

        ntrace=1
        tend=tbeg+(npt-1)*delt
c        numt=(tend-tbeg)/delt+1
        numt=npt
	do 4 j=1,numt
4	tref(j)=tbeg+(j-1)*delt

c
c   open output ascii files for different phase type:
c     itype=1: Ps
c     itype=2: P2p1s
c     itype=3: P1p2s
c     itype=4: P3s
c
C23456789012345678901234567890123456789012345678901234567890123456789012
c        if (itype.eq.1) then
c           open(out,file='PSMOUT.QBN',status='unknown'
c     &             ,form='unformatted',access='direct',recl=4)
c        else if (itype.eq.2) then
c           open(out,file='PPPSMOUT.QBN',status='unknown'
c     &             ,form='unformatted',access='direct',recl=4)
c        else if (itype.eq.3) then
c           open(out,file='PPSSMOUT.QBN',status='unknown'
c     &             ,form='unformatted',access='direct',recl=4)
c        else if (itype.eq.4) then
c           open(out,file='PSSSMOUT.QBN',status='unknown'
c     &             ,form='unformatted',access='direct',recl=4)
c        else
c           write(*,*) 'error: wrong phase type'
c           stop
c        endif
c
c  moveout table
c
	call table(itype,nslow,maxt,ttmo)
c
	do 6 j=1,numt
6	ysum(j)=0
	do 8 i=1,ntrace
8	maxy(i)=numt
c
c  Loop for traces
c
	maxtr=0
	do 100 itr=1,ntrace
	write(*,96)itr
96	format('  trace: ',i5)

c
c  read in data of one trace
c
c        read(in,*) ch,delta
c        read(in,*) ch,length
c        read(in,*) ch,slowness
c        read(in,*) (x(j),j=1,length)
c        read(in,*)

        delta=delt
        length=npt
	if (slowness.gt.slow2) then
	   write(*,89) slow2
89	   format(' slowness exceeds',f10.3,', neglected')
	   goto 100
	endif
	maxtr=maxtr+1
c
c  moveout table for this trace
c
	is1=int((slowness-slow1)/dslow)+1
	if(is1.eq.nslow) is1=is1-1
	is2=is1+1
	si1=slow1+(is1-1)*dslow
	si2=si1+dslow
	maxtable=maxt(is2)
	do 10 j=1,maxtable
	tt(j)=ttmo(is1,j)+(ttmo(is2,j)-ttmo(is1,j))
     &        *(slowness-si1)/(si2-si1)

10	continue
c
c  moveout correction
c
	do 20 j=1,numt
	if (tref(j).le.0) then
	   treal=tref(j)
	else
	   i1=int((tref(j)-time1)/dtime)+1
	   i2=i1+1
	   if (i2.gt.maxtable) then
	      write(*,911) treal
911	      format('  warning: maximum Pds delay time: ',f10.3,'s')
	      maxy(itr)=j-1
	      goto 21
	   endif
	   ti1=time1+(i1-1)*dtime
	   ti2=ti1+dtime
	   ttx=tt(i1)+(tref(j)-ti1)*(tt(i2)-tt(i1))/(ti2-ti1)
	   treal=tref(j)+ttx
	end if

	i1=int((treal-tbeg)/delta)+1

	if (i1.gt.length) then
	   write(*,*) '  warning: data not enough length'
	   maxy(itr)=j-1
	   goto 21
	else if (i1.eq.length) then
	   i1=i1-1
	else
	   i2=i1+1
	   ti1=tbeg+(i1-1)*delta
	   ti2=ti1+delta
	   y(j)=x(i1)+(treal-ti1)*(x(i2)-x(i1))/(ti2-ti1)
	   ysum(j)=ysum(j)+y(j)
	endif
20	continue
21	continue
c
c  output to file
c
	do 30 j=1,numt
	if (j.gt.maxy(itr)) y(j)=0
30	continue
c************************************
c        do 40 j=1,numt
c        recnum=j+(itr-1)*numt
c40      write(out,rec=recnum) y(j)
c************************************
        do 40 j=1,numt
40      x(j)=y(j)

100	continue

        return
	end


********************************************************************

	subroutine table(itype,nslow,maxt,ttpsmo)
	common /slow/ slow1,slow2,dslow
	common /time/ time1,time2,dtime
	dimension depco(500),vpco(500),vsco(500),layco(500)
	dimension dep(2000),vp(2000),vs(2000),hk(2000),ro(2000)
	dimension slowness(100),depth(200),ttps(100,200),ttps0(200)
	dimension t0(200),ttpsmo(100,200),maxdep(100),maxt(100)
	character model*50
c
c  parameters for moveout table
c
	slow1=0
	slow2=13
	dslow=0.2
	nslow=int((slow2-slow1)/dslow)+1

	depth1=0
	depth2=2000
	ddepth=20
	ndepth=int((depth2-depth1)/ddepth)+1

	time1=0
	time2=200
	dtime=2
	ntime=int((time2-time1)/dtime)+1

	do 3 i=1,nslow
3	maxt(i)=ntime

c
c  read in velocity model
c
	model='iasp91.dat'
	open(11,file=model,status='old')
	read(11,*)
	read(11,*)
	nlayco=0
	do 10 i=1,500
	read(11,*) depco(i),vpco(i),vsco(i),layco(i)
	if (abs(depco(i)).lt.0.001.and.abs(vpco(i)).lt.0.001
     1	.and.abs(vsco(i)).lt.0.001.and.abs(layco(i)).lt.0.001) 
     2	goto 11
	nlayco=nlayco+1
10	continue
11	close(11)

	maxdep0=0
	do 301 i=1,nslow
301	maxdep(i)=0

c
c  Loop for depth
c
	do 200 ldep=1,ndepth
	depthmax=depth1+ddepth*(ldep-1)
	depth(ldep)=depthmax
c
c  transformation of gradient model to homogeneous layered model
c
	lay=0
	do 20 i=1,nlayco
	if(layco(i).eq.0) goto 20
	vp0=vpco(i-1)
	vs0=vsco(i-1)
	dep0=depco(i-1)
	devp=(vpco(i)-vpco(i-1))/layco(i)
	devs=(vsco(i)-vsco(i-1))/layco(i)
	dedep=(depco(i)-depco(i-1))/layco(i)
	do 19 j=1,layco(i)
	lay=lay+1
	vp(lay)=vp0+devp*(j-0.5)
	vs(lay)=vs0+devs*(j-0.5)
	hk(lay)=dedep
	dep(lay)=dep0+dedep*(j-1)
	depm=dep(lay)+dedep
	if (depm.ge.depthmax) then
	   hk(lay)=hk(lay)-(depm-depthmax)
	   goto 21
	end if
19	continue
20	continue
21	continue
c
c  Earth Flattening Approximation
c
	call efa(lay,dep,hk,vp,vs,ro,1)
c
c  for reference slowness p=6.4
c
c	slow=6.4/111.195
        slow=0.06
	ttp=0
	tts=0
	xp=0
	xs=0

	do 80 i=1,lay
	pvp=slow*vp(i)
	pvs=slow*vs(i)

c   judge if post critical angle
	if (pvp.ge.1) goto 201

	h=hk(i)
	termp=1/sqrt(1-pvp*pvp)
	terms=1/sqrt(1-pvs*pvs)
	ttp=ttp+h*termp/vp(i)
	tts=tts+h*terms/vs(i)
	xp=xp+h*pvp*termp
	xs=xs+h*pvs*terms
80	continue
c
c   computes delay time for different phase type:
c     itype=1: Ps
c     itype=2: P2p1s
c     itype=3: P1p2s
c     itype=4: P3s
c
	if (itype.eq.1) then
	   ttps0(ldep)=tts-ttp-(xs-xp)*slow
	else if (itype.eq.2) then
	   ttps0(ldep)=tts+ttp-(xs+xp)*slow
	else if (itype.eq.3) then
	   ttps0(ldep)=2*tts-2*xs*slow
	else if (itype.eq.4) then
	   ttps0(ldep)=3*tts-ttp-(3*xs-xp)*slow
	else
	   write(*,*) 'error in subroutine: wrong phase type'
	   stop
	endif

	maxdep0=maxdep0+1

c
c  Main calculation, loop for slowness
c
	do 101 lslo=1,nslow
	slowness(lslo)=slow1+dslow*(lslo-1)
	slow=slowness(lslo)/111.195
	ttp=0
	tts=0
	xp=0
	xs=0

	do 100 i=1,lay
	pvp=slow*vp(i)
	pvs=slow*vs(i)

c   judge if post critical angle
	if (pvp.ge.1) goto 101

	h=hk(i)
	termp=1/sqrt(1-pvp*pvp)
	terms=1/sqrt(1-pvs*pvs)
	ttp=ttp+h*termp/vp(i)
	tts=tts+h*terms/vs(i)
	xp=xp+h*pvp*termp
	xs=xs+h*pvs*terms
100	continue
c
c   computes delay time for different phase type:
c     itype=1: Ps
c     itype=2: P2p1s
c     itype=3: P1p2s
c     itype=4: P3s
c
	if (itype.eq.1) then
	   ttps(lslo,ldep)=tts-ttp-(xs-xp)*slow
	else if (itype.eq.2) then
	   ttps(lslo,ldep)=tts+ttp-(xs+xp)*slow
	else if (itype.eq.3) then
	   ttps(lslo,ldep)=2*tts-2*xs*slow
	else if (itype.eq.4) then
	   ttps(lslo,ldep)=3*tts-ttp-(3*xs-xp)*slow
	else
	   write(*,*) 'error in subroutine: wrong phase type'
	   stop
	endif
	maxdep(lslo)=maxdep(lslo)+1
101	continue
200	continue
201	continue
c
c  differences of delay times
c
	do 120 i=1,nslow
	do 120 j=1,maxdep(i)
	ttps(i,j)=ttps(i,j)-ttps0(j)
120	continue
c
c  Interpolation for an equal-sampling reference delay-time array.
c
	do 130 i=1,nslow

	ind=1

	do 129 j=1,ntime
	t0(j)=time1+(j-1)*dtime

141	continue
	if (ttps0(ind).ge.t0(j)) then
	   if (ind.eq.1) then
	      ttpsmo(i,j)=ttps(i,1)
	   else if (ind.gt.maxdep(i)) then
	      maxt(i)=j-1
	      goto 130
	   else
	      ind1=ind-1
	      ttpsmo(i,j)=ttps(i,ind1)+(t0(j)-ttps0(ind1))*(ttps(i,ind)
     &                    -ttps(i,ind1))/(ttps0(ind)-ttps0(ind1))
	   end if
	else
	   ind=ind+1
	   goto 141
	end if

129	continue
130	continue

	return
	end

************************************************************

      subroutine efa(n,dep,h,vp,vs,ro,i)
c
c--- earth flattenning approximation for gradient model
c--- i=1(from spherical to flat), i.ne.1 (inverse)
c--- modefied from kosarev's "efal" in "bip.f"
c
      dimension dep(n),h(n),vp(n),vs(n),ro(n)
      if(i.eq.1) then
         za=0.
         zz=0.
         do k=1,n
c      write(*,*)'k=',k,' y1',y1,' dep,vp,vs,ro,h'
c     &,dep(k),vp(k),vs(k),ro(k),h(k)
              z1k=zz+h(k)*0.5
              zz=zz+h(k)
              y1=6370./(6370.-z1k)
              yz=6370./(6370.-zz)
              zm=6370.*alog(yz)
              h(k)=zm-za
              za=zm
              vp(k)=vp(k)*y1
              vs(k)=vs(k)*y1
              ro(k)=ro(k)/y1
              if (k.gt.1) dep(k)=dep(k-1)+h(k-1)
c      write(*,*)'k=',k,' y1',y1,' dep,vp,vs,ro,h'
c     &,dep(k),vp(k),vs(k),ro(k),h(k)
         end do
      else
         za=0.
         zz=0.
         do k=1,n
              z1k=zz+h(k)*0.5
              if(k.eq.n) z1k=zz
              zz=zz+h(k)
              z1k=6370.*(1.-exp(-z1k/6370.))
              zm=6370.*(1.-exp(-zz/6370.))
              y1=6370./(6370.-z1k)
              h(k)=zm-za
              za=zm
              vp(k)=vp(k)/y1
              vs(k)=vs(k)/y1
              ro(k)=ro(k)*y1
              if (k.gt.1) dep(k)=dep(k-1)+h(k-1)
         end do  
       end if
       return
       end
