util_drt.f

linux下开发的三维地震波场射线追踪偏移程序。在目录中执行make编译

      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_decode_value_1(value,n_value, card,name)
      character*(*) value,card,name
      integer n_value
c get character value of a variable 'name' from card.  name=value.
cndxc decode_value_1( c
      character ccard*160,cname*80
      integer ic1,ic2,in1,nname,jc1,ncard,igap,ibegin
      logical lquote,util_spac
c
      ncard = len(card)

c  modify so # sign comments out following characters dwh 05-03-94
      do ic1 = 1 , ncard
        if (card(ic1:ic1) .eq. '#') then
          ncard = ic1 - 1
          goto 301
        endif    ! if (card(ic1:ic1) .eq. '#') then
      enddo    ! do ic1 = 1 , ncard
  301 continue

c capitalize name and card
      call util_caps(card, ccard)
      call util_caps(name, cname)
      call util_clft(cname)
      n_value = 0
      value = ' '
      call util_lenl(nname, name)
      nname = min(80, nname)
      do 300 ic1=1,ncard
        if(card(ic1:ic1).eq.'=') then
c count igap, the number of intervening blanks
          igap = 0
   50     continue
          ic2 = ic1 - igap - 1
          if(ic2.lt.1) goto 300
          if(ccard(ic2:ic2).eq.' ') then
            igap = igap + 1
            goto 50
          endif
c see if string matches before blanks
          do 100 in1=1,nname
            ic2 = ic1 - nname - 1 + in1 - igap
              if(ic2.lt.1) goto 300
              if(ccard(ic2:ic2).ne.cname(in1:in1)) goto 300
  100     continue
c check to see if cname is not the last part of another name.
          ic2 = ic1 - nname - 1 - igap
          if(ic2.gt.0) then
            if (.not.util_spac(card(ic2:ic2))) goto 300
c            if(      ccard(ic2:ic2).ne.' '.and.
c     &               ccard(ic2:ic2).ne.','.and.
c     &               ccard(ic2:ic2).ne.';'.and.
c     &               ccard(ic2:ic2).ne.'('         ) goto 300
          endif
c have a match ; ignore first blanks after equals sign
          ibegin = ic1 + 1
  150     continue
            if(card(ibegin:ibegin).eq.' ') then
              ibegin = ibegin + 1
              if(ibegin.gt.ncard) goto 300
              goto 150
            endif
c check to see if string is in quotes
          lquote = (card(ibegin:ibegin).eq.'"')
          if(lquote) ibegin = ibegin + 1
c start loop to set output string
          value = ' '
          jc1 = ibegin - 1
          n_value = 1
  200     continue
            ic2 = jc1 + n_value
            if(ic2.le.ncard) then
              if( ((.not.lquote).and.(.not.util_spac(card(ic2:ic2))))
     &      .or. (lquote.and.card(ic2:ic2).ne.'"') ) then
c              if( ((.not.lquote).and.
c     &           card(ic2:ic2).ne.' '.and.
c     &           card(ic2:ic2).ne.')'.and.
c     &           card(ic2:ic2).ne.';'.and.
c     &           card(ic2:ic2).ne.',').or.
c     &           (lquote.and.card(ic2:ic2).ne.'"') ) then
                value(n_value:n_value) = card(ic2:ic2)
                n_value = n_value + 1
                goto 200
              endif
            endif
          n_value = n_value - 1
        endif
  300 continue
cc    write(6,*) 'name value ',cname(:nname),' ',value(:n_value), n_value
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_decode_value_2(value,n_value, name,i_file)
      character*(*) value,name
      integer n_value,i_file
c save is changed to integer!
c     save mlines,nforl
      integer mlines,nforl
c get the value of a variable 'name' from device i_file
c  use format   'name=value',  returned value is a string.
c  string is delimited on right by blank, comma, or parenthesis.
c  keep last assignment in file
c first open i_file with
      character card*160, val*80
c save is changed to integer!
c     integer nname,nval,nlines,jlines,mlines,iforl,jforl,nforl
      integer nname,nval,nlines,jlines,iforl,jforl
      integer i_rewind
      data mlines,nforl/200,1/
      data    i_rewind/0/
      if (i_rewind .ne. 1) rewind(i_file)
      n_value = 0
      nlines = 1
      iforl = 0
  100 continue
        read(i_file,1401,end=200,err=1301) card
C      PRINT'('' decode_value_2 CARD='',A60)',CARD(1:MIN(LEN(CARD),60))
        call util_decode_value_1(val,nval, card,name)
        if(nval.gt.0) then
	  value = val(:nval)
	  n_value = nval
	  iforl = iforl + 1
	  if (iforl .eq. nforl) goto 200
        endif
      nlines = nlines + 1
      if(nlines.lt.mlines) goto 100
  200 continue
        call util_lenl(nname,name)
cc        write(6,*) 'name value ',name(:nname),' ',value(:n_value)
      return
 1301 continue
c      write(6,*) 'error reading device ',i_file
      return
 1401 format(160a)
      entry util_plin(jlines)
c set the number of lines to read in decode_value_2
      mlines = jlines
      return
      entry util_glin(jlines)
c return the number of lines to read in decode_value_2
      jlines = mlines
      return
      entry util_porl(jforl)
c  se the number of occurences to search for
      nforl = jforl
      return
      entry util_gorl(jforl)
c  return the number of occurences to search for
      jforl = nforl
      return

      entry util_set_rewind
      i_rewind = 0
      return

      entry util_set_no_rewind
      i_rewind = 1
      return

      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_decode_r(rvalue, name)
      real rvalue
      integer ivalue,nchar
      character*(*) name,cvalue
c get real value from file; "name=rvalue" oepn set i_file, close
      integer n_value,i_file
      real r
      character*80 value
c     character*20 c20
      data i_file/-1/
        if(i_file.lt.0) return
cc this is commoned because util_decode_value_2() is commoned
        call util_decode_value_2(value,n_value, name,i_file)
        if(n_value.ge.1) then
          call util_dcod(rvalue, value(:n_value))
        endif
C      PRINT'('' GVR VALUE='',G16.3,'' NAME='',A16)',RVALUE,NAME
      return
c23456789012345678901234567890123456789012345678901234567890123456789012
      entry util_decode_i(ivalue, name)
c get an integer value from a parameter file
        if(i_file.lt.0) return
cc this is commoned because util_decode_value_2() is commoned
        call util_decode_value_2(value,n_value, name,i_file)
        if(n_value.ge.1) then
          call util_dcod(r,value(:n_value))
          ivalue = int(r+0.499)
        endif
C      PRINT'('' GVI IVALUE='',I8,'' NAME='',A16)',IVALUE,NAME
      return
c23456789012345678901234567890123456789012345678901234567890123456789012
      entry util_decode_c(cvalue,nchar, name)
c get a character string from a parameter file
        if(i_file.lt.0) then
          nchar = 0
          return
        endif
cc this is commoned because util_decode_value_2() is commoned
        call util_decode_value_2(value,n_value, name,i_file)
        if(n_value.ge.1) then
          cvalue = ' '
          cvalue = value(:n_value)
          nchar = n_value
        endif
C      PRINT'('' GVC VALUE='',A16,'' NAME='',A16)',CVALUE,NAME
      return

c23456789012345678901234567890123456789012345678901234567890123456789012
      entry util_get_device(j_file)
c call this to find out what the device (unit) number is open
        j_file = i_file
      return

c23456789012345678901234567890123456789012345678901234567890123456789012
      entry util_put_device(j_file)
c call this to find out what the device (unit) number is open
        i_file = j_file
      return

      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_cadp(c, nc)
      character*(*) c
      integer nc
c add a period to a string, so that resembles floating point number.
cndxc cadp( c
      integer i
      character*80 card
      card = ' '
      card = c(:nc)
      call util_clft(card)
      c(:nc) = card(:nc)
      do 100 i=1,nc
        if(c(i:i).eq.' '.or.c(i:i).eq.'.') goto 200
  100 continue
      nc = nc + 1
      i = nc
  200 continue
      c(i:i) = '.'
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_clft(c)
      character*(*) c
c get rid of leading blanks, only one word moved, up to first blank.
cndxc clft( c
      integer i,i1,n,i2,nall,nc,ncrest
      nc = len(c)
      do 100 i=1,nc
        if(c(i:i).ne.' ') goto 200
  100 continue
      return
  200 continue
      if(i.eq.1) return
      ncrest = nc-i+1
      call util_lenr(n, c(i:nc),ncrest)
      nall = i+n-1
      do 300 i1=1,nc
        i2 = i1 + i - 1
        if(i1.le.n) then
          c(i1:i1) = c(i2:i2)
        else
          c(i1:i1) = ' '
        endif
  300 continue
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      function util_invert_1(x)
      implicit none
      real util_invert_1
      real x
c     real eps
c     data eps/1.e-10/
      util_invert_1 = 0.
      if (x .ne. 0.) util_invert_1 = 1. / x

c      if (abs(x) .ge. eps) then

c        util_invert_1 = 1. / x

c      else    ! if (abs(x) .ge. eps) then

c        util_invert_1 = 0.

c      endif    ! if (abs(x) .ge. eps) then

      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      integer function util_len_r(str)
c  find the last non blank character
      character str*(*)
      do j = len(str) , 1 , -1
        util_len_r = j
        if (str(j:j) .ne. ' ') return
      enddo
      util_r = 0
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      logical function util_spac(card)
c  is card oone of the delimiters
      character *1 card
      parameter (mc=3)
      character c(mc)*1
      data c/' ',',','('/
      util_spac = .false.
      do 1 i = 1 , mc
        util_spac = util_spac .or. (card .eq. c(i))
    1 continue
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      real function util_rd(x)
      implicit none
      real     x
      util_rd = x * 90. / asin(1.)
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      real function util_dr(x)
      implicit none
      real     x
      util_dr = x * asin(1.) / 90.
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      integer function util_fetch_i(name,value)
      implicit  none

      character name*(*)
      integer   value

      integer   x

      integer i_call
      data    i_call/0/
      i_call = i_call + 1

      x = -999

        call util_decode_i(x,name)

      if (x .ne. -999) then
        util_fetch_i = 1
        value = x
      else
        util_fetch_i = 0
      endif

      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      integer function util_fetch_r(name,value)
      implicit  none

      character name*(*)
      real      value

      real      x

      integer i_call
      data    i_call/0/
      i_call = i_call + 1

      x = -999.

        call util_decode_r(x,name)

      if (abs(x+999.) .gt. .01) then
        util_fetch_r = 1
        value = x
      else
        util_fetch_r = 0
      endif

      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      integer function util_fetch_c(name,value)
      implicit  none

      character name*(*)
      character value*(*)

      character x*132
      integer nx

      integer i_call
      data    i_call/0/
      i_call = i_call + 1

      x = '999'

        call util_decode_c(x,nx,name)

      if (x(1:3) .ne. '999') then
        util_fetch_c = 1
        value = x
      else
        util_fetch_c = 0
      endif

      return
      end
c23456789012345678901234567890123456789012345678901234567890123456789012
      integer function util_r(str)
c  find the last non blank character
      character str*(*)
      do j = len(str) , 1 , -1
        util_r = j
        if (str(j:j) .ne. ' ') return
      enddo
      util_r = 0
      return
      end