vzestsubf.f

su 的源代码库

* Copyright (c) Colorado School of Mines, 2006.
* All rights reserved.

      subroutine forsub(iflag, nbufmax, buf)        

      implicit none

      integer iflag
      integer nbufmax
      real buf(1)

      integer npicks
      save npicks

      integer nxrt,nyrt
      save nxrt,nyrt

      real vlambda
      real v0lambda
      real v1lambda
      real vzlambda
      real zlambda
      save vlambda,v0lambda,v1lambda,vzlambda,zlambda

      integer niterations
      save  niterations

      real topcmean
      real basecmean
      save topcmean,basecmean

      real xupmaxconst
      real xdnmaxconst
      save xupmaxconst,xdnmaxconst

      real dxrt,dyrt
      save dxrt,dyrt

      integer ixdisp,iydisp
      save ixdisp,iydisp

      integer iseed
      save iseed

      integer isort(2)
      save isort

      integer nsort
      real sort1
      real sort2
      save nsort,sort1,sort2 
 
      integer nxrtbeg
      integer nxrtend
      integer nyrtbeg
      integer nyrtend
      save  nxrtbeg,nxrtend,nyrtbeg,nyrtend

      real w_eps
      real azimuth
      save w_eps,azimuth

      character*120 fnames(2)
      save fnames

      character*120 topcmigfile
      save topcmigfile

      real topc
      character*120 topcgmigfile
      save topc,topcgmigfile

      real topcg
      character*120 topzgridfile
      save topcg,topzgridfile

      character*120 basecmigfile
      character*120 basezgridfile
      save basecmigfile,basezgridfile

      character*120 dvxfile
      character*120 dvyfile
      character*120 dvzfile
      save dvxfile,dvyfile,dvzfile

      character*120 c0newfile
      save c0newfile

      character*120 g0file
      character*120 g1file
      character*120 g2file
      character*120 g3file
      save g0file,g1file,g2file,g3file

      integer nxht,nyht
      integer nmva
      save nxht,nyht,nmva

      integer neqns,nentries,ngrid
      save neqns,nentries,ngrid

      integer p_topcmig    !real (nxrt,nyrt) velocity grid at the top for small v
      integer p_topcgmig   !real (nxrt,nyrt) velocity gradient at the top
      integer p_topcnew    !real (nxrt,nyrt) velocity grid at the top for small v
      integer p_topzgrid   !real (nxrt,nyrt) depth grid at the top
      integer p_basecmig   !real (nxrt,nyrt) velocity grid at the base for small v
      integer p_basezgrid  !real (nxrt,nyrt) depth grid at the base
      integer p_g          !real (npicks,nxrt,nyrt,4) derivatives with repsect to
      integer p_dvz        !real (nxrt,nyrt) derivatives with repsect to
      integer p_dvzold     !real (nxrt,nyrt) derivatives with repsect to
      integer p_dvx        !real (nxrt,nyrt) derivatives with repsect to
      integer p_dvy        !real (nxrt,nyrt) derivatives with repsect to
      integer p_dvxwork    !real (nxrt,nyrt) derivatives with repsect to
      integer p_work       !real (nxht,nyht)
      integer p_icol       !integer (nentries) column positions of nonzeros a entries
      integer p_irow       !integer (nentries) row positions of nonzeros a entries
      integer p_a          !real (nentries) nonzero a entries
      integer p_b          !real (neqns) the right hand side (ixht+(iyht-1)*nxht)
      integer p_x          !real (nmva) the unknown dvz (ixht+(iyht-1)*nxht)
      integer p_xupmax     !real (nmva) maximum up-perturbation allowed
      integer p_xdnmax     !real (nmva) maximum dn-perturbation allowed
      integer p_xbak       !real (nmva) a copy of x
      integer p_y          !real (neqns) working global parms
      integer p_q          !real (neqns)
      integer p_s          !real (neqns)
      integer p_p          !real p(nmva)
      integer p_r          !real r(nmva)
      integer p_tmisfit    !real tmisfit(npicks,nxrt,nyrt)
      integer p_zmisfit    !real zmisfit(npicks,nxrt,nyrt)

      save p_topcmig    !real (nxrt,nyrt) velocity grid at the top for small v
      save p_topcgmig   !real (nxrt,nyrt) velocity gradient at the top
      save p_topcnew    !real (nxrt,nyrt) velocity grid at the top for small v
      save p_topzgrid   !real (nxrt,nyrt) depth grid at the top
      save p_basecmig   !real (nxrt,nyrt) velocity grid at the base for small v
      save p_basezgrid  !real (nxrt,nyrt) depth grid at the base
      save p_g          !real (npicks,nxrt,nyrt,4) derivatives with repsect to
      save p_dvz        !real (nxrt,nyrt) derivatives with repsect to
      save p_dvzold     !real (nxrt,nyrt) derivatives with repsect to
      save p_dvx        !real (nxrt,nyrt) derivatives with repsect to
      save p_dvy        !real (nxrt,nyrt) derivatives with repsect to
      save p_dvxwork    !real (nxrt,nyrt) derivatives with repsect to
      save p_work       !real (nxht,nyht)
      save p_icol       !integer (nentries) column positions of nonzeros a entries
      save p_irow       !integer (nentries) row positions of nonzeros a entries
      save p_a          !real (nentries) nonzero a entries
      save p_b          !real (neqns) the right hand side (ixht+(iyht-1)*nxht)
      save p_x          !real (nmva) the unknown dvz (ixht+(iyht-1)*nxht)
      save p_xupmax     !real (nmva) maximum up-perturbation allowed
      save p_xdnmax     !real (nmva) maximum dn-perturbation allowed
      save p_xbak       !real (nmva) a copy of x
      save p_y          !real (neqns) working global parms
      save p_q          !real (neqns)
      save p_s          !real (neqns)
      save p_p          !real p(nmva)
      save p_r          !real r(nmva)
      save p_tmisfit    !real tmisfit(npicks,nxrt,nyrt)
      save p_zmisfit    !real zmisfit(npicks,nxrt,nyrt)

      integer size_topcmig    !real (nxrt,nyrt) velocity grid at the top for small v
      integer size_topcgmig   !real (nxrt,nyrt) velocity gradient at the top
      integer size_topcnew    !real (nxrt,nyrt) velocity grid at the top for small v
      integer size_topzgrid   !real (nxrt,nyrt) depth grid at the top
      integer size_basecmig   !real (nxrt,nyrt) velocity grid at the base for small v
      integer size_basezgrid  !real (nxrt,nyrt) depth grid at the base
      integer size_g          !real (npicks,nxrt,nyrt,4) derivatives with repsect to
      integer size_dvz        !real (nxrt,nyrt) derivatives with repsect to
      integer size_dvzold     !real (nxrt,nyrt) derivatives with repsect to
      integer size_dvx        !real (nxrt,nyrt) derivatives with repsect to
      integer size_dvy        !real (nxrt,nyrt) derivatives with repsect to
      integer size_dvxwork    !real (nxrt,nyrt) derivatives with repsect to
      integer size_work       !real (nxht,nyht)
      integer size_icol       !integer (nentries) column positions of nonzeros a entries
      integer size_irow       !integer (nentries) row positions of nonzeros a entries
      integer size_a          !real (nentries) nonzero a entries
      integer size_b          !real (neqns) the right hand side (ixht+(iyht-1)*nxht)
      integer size_x          !real (nmva) the unknown dvz (ixht+(iyht-1)*nxht)
      integer size_xupmax     !real (nmva) maximum up-perturbation allowed
      integer size_xdnmax     !real (nmva) maximum dn-perturbation allowed
      integer size_xbak       !real (nmva) a copy of x
      integer size_y          !real (neqns) working global parms
      integer size_q          !real (neqns)
      integer size_s          !real (neqns)
      integer size_p          !real p(nmva)
      integer size_r          !real r(nmva)
      integer size_tmisfit    !real tmisfit(npicks,nxrt,nyrt)
      integer size_zmisfit    !real zmisfit(npicks,nxrt,nyrt)

      save size_topcmig    !real (nxrt,nyrt) velocity grid at the top for small v
      save size_topcgmig   !real (nxrt,nyrt) velocity gradient at the top
      save size_topcnew    !real (nxrt,nyrt) velocity grid at the top for small v
      save size_topzgrid   !real (nxrt,nyrt) depth grid at the top
      save size_basecmig   !real (nxrt,nyrt) velocity grid at the base for small v
      save size_basezgrid  !real (nxrt,nyrt) depth grid at the base
      save size_g          !real (npicks,nxrt,nyrt,4) derivatives with repsect to
      save size_dvz        !real (nxrt,nyrt) derivatives with repsect to
      save size_dvzold     !real (nxrt,nyrt) derivatives with repsect to
      save size_dvx        !real (nxrt,nyrt) derivatives with repsect to
      save size_dvy        !real (nxrt,nyrt) derivatives with repsect to
      save size_dvxwork    !real (nxrt,nyrt) derivatives with repsect to
      save size_work       !real (nxht,nyht)
      save size_icol       !integer (nentries) column positions of nonzeros a entries
      save size_irow       !integer (nentries) row positions of nonzeros a entries
      save size_a          !real (nentries) nonzero a entries
      save size_b          !real (neqns) the right hand side (ixht+(iyht-1)*nxht)
      save size_x          !real (nmva) the unknown dvz (ixht+(iyht-1)*nxht)
      save size_xupmax     !real (nmva) maximum up-perturbation allowed
      save size_xdnmax     !real (nmva) maximum dn-perturbation allowed
      save size_xbak       !real (nmva) a copy of x
      save size_y          !real (neqns) working global parms
      save size_q          !real (neqns)
      save size_s          !real (neqns)
      save size_p          !real p(nmva)
      save size_r          !real r(nmva)
      save size_tmisfit    !real tmisfit(npicks,nxrt,nyrt)
      save size_zmisfit    !real zmisfit(npicks,nxrt,nyrt)

      if (iflag.eq.1) then        !just return the size of buf, no raytracing
      
      call getparms_pracmva(
     +  npicks,                  !integer npicks=2
     +  niterations,             !integer niterations=40
     +  vlambda,                 !real vlambda=3.0
     +  v0lambda,                !real v0lambda=1.0
     +  v1lambda,                !real v1lambda
     +  vzlambda,                !real vzlambda
     +  zlambda,                 !real zlambda
     +  w_eps,                   !real w_eps /0.1/
     +  azimuth,                 !real azimuth /0.0/
     +  xupmaxconst,             !real xupmaxconst=100
     +  xdnmaxconst,             !real xdnmaxconst=-100
     +  topcmean,                !real topcmean
     +  basecmean,               !real basecmean
     +  nxrt,                    !number of samples in x
     +  nyrt,                    !number of samples in y
     +  nxrtbeg,nxrtend,         !CIGs to be solved
     +  nyrtbeg,nyrtend,         !CIGs to be solved
     +  dxrt,                    !CIG spacing