util_drt.f

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

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

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

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_setr(n,x,x0)
      implicit none
      integer  i,n
      real     x(1),x0
      do i = 1 , n
        x(i) = x0
      enddo
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_seti(n,x,x0)
      implicit none
      integer  i,n
      integer  x(1),x0
      do i = 1 , n
        x(i) = x0
      enddo
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_lini(n,x,x0,dx)
      implicit none
      integer  i,n
      integer  x(1),x0,dx
      do i = 1 , n
        x(i) = x0 + (i - 1 ) * dx
      enddo
      return
      end
							   
c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_invert(n,x)
      implicit none
      integer  i,n
      real     x(1)
      do i = 1 , n
      if (x(i) .ne. 0.) x(i) = 1. / x(i)
      enddo
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_min_max(x_min,x_max,n,x)
      implicit none
      integer  i,n
      real     x(1),x_min,x_max
      x_min = 0.
      x_max = 0.
      if (n .eq. 0) return

      x_min = x(1)
      x_max = x(1)
      do i = 1 , n
        x_min = min(x_min,x(i))
        x_max = max(x_max,x(i))
      enddo
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_min_max_i(x_min,x_max,n,x)
      implicit none
      integer  i,n
      integer  x(1),x_min,x_max
      x_min = 0
      x_max = 0
      if (n .eq. 0) return

      x_min = x(1)
      x_max = x(1)
      do i = 1 , n 
        x_min = min(x_min,x(i))
        x_max = max(x_max,x(i))
      enddo   
      return  
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_open_file(
     1i_file,file,status,form,n_rec,i_err)
      implicit  none
      integer   i_file
      character file*(*),status*(*),form*(*)
      integer   n_rec,i_err

      i_err = 0

      call util_get_lun(i_file,i_err)
      if (i_err .ne. 0) goto 998

      if (form .eq. 'direct' .or. form .eq. 'DIRECT') then

        open(i_file,file=file,status=status,form=form,err=999)

      else

        open(i_file,file=file,status=status,form=form
     1,recl=n_rec,err=999)

      endif

      return

  998 continue
      print'(/,'' error in util_open_file getting unit number'')'
      goto 999

  999 continue
      print'(/,'' error in util_open_file''
     1,/,'' i_file='',i5,'' file='',a
     1,/,'' status='',a16,'' form='',a16,'' recl='',i5)'
     1,i_file,file,status,form,n_rec
      i_err = -1
      return
      end


c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_get_file_name(prompt,file,ext)
      character *(*) prompt,file,ext
      character crd80*80
    1 continue

      crd80 = ' '
      call util_add_character(prompt,crd80)
      call util_add_character(' -default=',crd80)
      call util_add_character(file,crd80)
      call util_add_character(' ext=',crd80)
      call util_add_character(ext,crd80)
      print'(a)',crd80
      crd80 = ' '
      read (5,'(a)',err=1) crd80
      if (crd80 .ne. ' ') read(crd80,'(a)')file
      if (file .eq. ' ') goto 1
      call util_add_ext(file,ext)

      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_add_character(c1,c2)
c  add c1 to end of c2
      integer   util_r
      character c1*(*),c2*(*)
      integer   lc1,lc2,n

      lc1 = util_r(c1)
      lc2 = util_r(c2)
      n = min(lc1,len(c2)-lc2)
      write(c2(lc2+1:lc2+n),'(a)')c1(1:n)

      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_add_ext(fname,ext)
      character*(*) fname,ext
      ientry = 1
      go to 1
      entry util_add_extrp (fname,ext)
      entry util_add_ext_replace (fname,ext)
      ientry = 2
   1  iclose = index (fname,']')
      if (iclose.eq.0)  iclose = index (fname,'>')
      idot = index (fname(iclose+1:),'.')
      if (idot.gt.0 .and. ientry.eq.1)  return
      isem = index (fname(iclose+1:),';')
      if (isem .gt. 0)  then
        if (idot.eq.0)  idot = isem
        fname = fname(:iclose+idot-1)//'.'//ext//fname(iclose+isem:)
      else
        if (idot.gt.0)  then
          fname = fname(:iclose+idot)//ext
        else
          ilast = index (fname(iclose+1:),' ')
          if (ilast.eq.0)  return
          fname = fname(:iclose+ilast-1)//'.'//ext
        end if
       end if

       return
       end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_work(i_work,m_work,j_work,n_work)
c  assign work space within an array
c
c  i_work = current pointer within work array
c  m_work = total memory in work array
c  j_work = pointer for this memory allocation
c  n_work = amount of memory to allocate in this call
c
c  i_work and m_work are initialized by util_wors and modified by
c  other routines, they should never be altered by the user outside
c  of util_wor...
      implicit none

      integer i_work,m_work,j_work,n_work,i_err

      j_work = i_work
      i_work = i_work + n_work

      return
	
c23456789012345678901234567890123456789012345678901234567890123456789012
      entry util_wors(i_work,m_work,n_work)
c  initalize the number of word savaliable to n_work
c  and the pointer to 1
      i_work = 1
      m_work = n_work

      return

c23456789012345678901234567890123456789012345678901234567890123456789012
      entry util_worl(i_work,m_work,n_work)
c  return the number of words remaining
      n_work = m_work - i_work + 1

      return     

c23456789012345678901234567890123456789012345678901234567890123456789012
      entry util_woru(i_work,m_work,n_work)
c  return the number of word used
      n_work = i_work - 1

      return

c23456789012345678901234567890123456789012345678901234567890123456789012
      entry util_worc(i_work,m_work,i_err)
c  check if we have used more memory than allowed

      i_err = 0
      if (i_work-1 .gt. m_work) then
        print'(/,'' error in work used='',i8,'' have='',i8)'
     1,i_work-1,m_work
        i_err = -1
      endif    ! if (i_work-1 .gt. m_work) then

      return
      end
	

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_get_lun(lun,i_err)
      implicit none
      integer lun,i,i_err
      logical quest
      integer lstart,lstop
      parameter (lstart=20,lstop=99)
      integer last,list(lstop)
      save    last,list
      data    last,list/lstop,lstop*0/

      i_err = 0
      do i=lstart,lstop
           last=last+1
           if (last.gt.lstop) last=lstart
           inquire (last,named=quest,err=999)
           if (.not.quest) then
                list(last)=1
                lun=last
                return
           end if
      end do

999   print *, 'util_get_lun failed'
      i_err = -1
      return

c23456789012345678901234567890123456789012345678901234567890123456789012
      entry util_get_lun_s
      do i=lstart,lstop
           if (list(i).gt.0) then
                close (i)
                list(i)=0
           end if
      end do
      last=lstop
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_caps(c_inp,c_out)
c capitalize an ascii string
      implicit  none

      character c_inp*(*),c_out*(*)

      character c_tmp*132
      character small*26,big*26
      integer   nc,ic1,ic2
      data      small/'abcdefghijklmnopqrstuvwxyz'/
      data      big/'ABCDEFGHIJKLMNOPQRSTUVWXYZ'/

      c_tmp = c_inp
      c_out = ' '
      c_out = c_tmp
      nc = len(c_out)

      do ic1 = 1 , nc

        do ic2 = 1 , 26

          if (c_out(ic1:ic1) .eq. small(ic2:ic2)) then

            c_out(ic1:ic1) = big(ic2:ic2)
            goto 1

          endif    ! if (c_out(ic1:ic1).eq.small(ic2:ic2)) then

        enddo    ! do ic2 = 1 , 26

    1   continue

      enddo    ! do ic1 = 1 , nc

      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_dcod(value, card)
      real value
      character*(*) card
c decode a real number, perhaps in scientific notation.
cndxi dcod( i
      integer n,i,n1,n2
      logical ee
      real r1,r2
      character*20 c20
c shift to left
      call util_clft(card)
c find out if in exponential notation
      n = len(card)
      ee = .false.
      do 100 i=1,n
        ee = (card(i:i).eq.'e'.or.card(i:i).eq.'E')
        if(ee) then
          n1 = i - 1
          n2 = i + 1
          goto 200
        endif
  100 continue
  200 continue
      if(.not.ee) then
c...        no exponent
        c20 = ' '
        c20 = card
        call util_cadp(c20,20)
        read(c20,1401,err=1301) value
      else
c...        have an exponent, read mantissa first
        c20 = ' '
        c20 = card(:n1)
        call util_cadp(c20,20)
        read(c20,1401,err=1301) r1
c...        read exponent second
        c20 = ' '
        c20 = card(n2:)
        call util_cadp(c20,20)
        read(c20,1401,err=1301) r2
        value = r1 * exp(log(10.)*r2)
      endif
      return
 1301 continue
c this is commoned because util_heyu() is commoned
c       call util_heyu('dcod: problem decoding card')
c       call util_heyu(card)
      return
 1401 format(f20.7)
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_lenl(n, c)
      character*(*) c
      integer n
c find the length of a string before first blank, from left.
cndxc lenl( c
      integer nc,i
      nc = len(c)
      do 100 i=1,nc
        n = i
        if(c(n:n).eq.' ') goto 200
  100 continue
      n = nc + 1
c break
  200 continue
      n = n - 1
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_lenp(n, c)
      character*(*) c
      integer n
c find the length of a string before first period, from right
cndxc lenp( c
c stop at first bracket ]. if no period stop before first blank.
      integer nc,ncb,i
      nc = len(c)
      ncb = nc + 1
      do 100 i=nc,1,-1
        n = i
        if(c(n:n).eq.' ') ncb = n
        if(c(n:n).eq.']') goto 150
        if(c(n:n).eq.'.') goto 200
  100 continue
  150 continue
      n = ncb
  200 continue
      n = n - 1
      return
      end

c23456789012345678901234567890123456789012345678901234567890123456789012
      subroutine util_lenr(n, c,nc)
      character*(*) c
      integer n,nc
c find the lenth of a string before first blank, from right
cndxc lenr( c
      integer i
      do 100 i=nc,1,-1
        n = i
        if(c(n:n).ne.' ') goto 200
  100 continue
      n = 1
  200 continue
      return