# 1 "<stdin>"
# 1 "<built-in>"
# 1 "<command line>"
# 1 "<stdin>"
!<;
!dip_field.x <in.H >out.H
!
!Input Parameters:
!
!
!Output Parameters:
!
!
!
!Description:
!
!
!
!>
!-------------------------------------------------
!
!Author: Robert Clapp, ESMB 463, 7230253
!
!Date Created:Mon May 21 15:10:48 PDT 2001
!
!Purpose:
!
module calc_vertical_moveout_mod
  use sep3d_struct_mod
  implicit none
  contains
  logical function calc_vertical_moveout(sxy,syz,coher,image,npts)
    calc_vertical_moveout=.false.
    if (verb) then
      write(0,*) "BEFORE FIND POINT LIST"
    end if
    if (.not. find_good_pts(sxz,syz,coher,image)) then
      write(0,*) "trouble finding acceptable points"
      return
    end if
    if (.not. calc_semblance_at_pts(npts)) then
      write(0,*) "trouble calcucating at selected pts"
      return
    end if
    calc_vertical_moveout=.true.
  end function
  logical function calc_semblance_at_pts(npts)
    integer :: npts
    type(sep3d) :: moveout
    integer, external :: auxin
    real, allocatable :: myvel(:),gather(:,:),mysemb(:)
    integer :: nv(3),ierr
    integer :: i1,i2,i3,i4,ix,iy,iz,iout,mymax(1),i,nout
    real :: header(4),maxme,mypct
    real :: min_semb,max_semb,dsemb
    logical :: keep
    integer, external :: sep3d_set_ntraces,getch
    integer :: nignore
    real ::max_s
    nout=0
    calc_semblance_at_pts=.false.
    if (.not. setup_semb_wt_moveout(.true.)) then
      write(0,*) "trouble setting up semb_wt_moveout"
      return
    end if
    allocate(semb_field(3*n_d_rms_semb))
    iout=0
    i3=-1
    i4=-1
    allocate(gather(mig%n(1),mig%n(2)))
    call moveout_check_init()
    pct_keep_semb=pct_keep_semb/100.
    do i2=1,npts
      if (verb .and. mod(i2,(npts/10)).eq.1) then
        write(0,*) "calculating semblance for ",i2," of ", npts
      end if
      ix=(pts_field(1,i2)-mig%o(3))/mig%d(3)+1.5
      if (sep3d_ndims(mig).eq.4) then
        iy=(pts_field(2,i2)-mig%o(4))/mig%d(4)+1.5
      end if
      iy=1
      iz=(pts_field(3,i2)-mig%o(1))/mig%d(1)+1.5
      if (is_2d) then
        iy=1
      end if
      if (i3.ne.ix .or. i4.ne. iy) then
        i1=ix+(iy-1)*mig%n(3)
        call sseek_block("mig",i1,size(gather)*4,0)
        call sreed("mig",gather,size(gather)*4)
        if (.not. change_semb_loc(pts_field(1:2,i2))) then
          write(0,*) "Trouble changing semblance location"
          return
        end if
        i3=ix
        i4=iy
      end if
      call calc_semblance(pts_field(:,i2),gather,semb_field,min_semb&
        &,max_semb)
      dsemb=(max_semb-min_semb)/n_d_rms_semb/3
      maxme=maxval(semb_field)
      mymax=maxloc(semb_field)
      mypct=(maxme-sum(semb_field)/size(semb_field))/(sum(semb_field)&
        &/size(semb_field))
      if (mypct > pct_keep_semb .and. maxme>min_keep_semb .and. mymax&
        &(1)>2.*size(semb_field)/6 .and. mymax(1)<4.*size(semb_field)/6 ) then
        do i=1,nignore
          header(1:3)=pts_field(:,i2)
          call srite("moveout",semb_field,size(semb_field)*4)
          call srite("semb",(mymax(1)-1)*dsemb+min_semb,4)
          call srite("wt",maxme,4)
          nout= nout+1
          max_s=(mymax(1)-1)*dsemb+min_semb
          call add_moveout(gather,pts_field(:,i2), max_s)
          header(4)=wt_calc_variance(max_s,min_semb,dsemb,n_d_rms_semb&
            &,semb_field)
          call sep_put_val_headers("semb",nout,1,header)
          call sep_put_val_headers("moveout",nout,1,header)
          call sep_put_val_headers("wt",nout,1,header)
        end do
      else
        write(0,*) "killed  pt2",i2,mypct,maxme,pct_keep_semb&
          &,min_keep_semb
      end if
    end do
    call finish_moveout()
    if (.not.finish_semb_wt_moveout(nout,.true.)) then
      write(0,*) "trouble finishing semb_wt_moveout"
      return
    end if
    deallocate(gather,semb_field)
    deallocate(pts_field)
    calc_semblance_at_pts=.true.
  end function
end module
