ungrib/src/module_stringutil.F

   1 module stringutil
   2
   3 !BUG: STRSIZE should be as large as the longest string length used in WPS
   4    integer, parameter :: STRSIZE = 1024
   5
   6    contains
   7
   8    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
   9    ! Name: despace
  10    !
  11    ! Purpose: Returns a string containing the path to the file specified by s.
  12    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  13    function get_path(s)
  14
  15       implicit none
  16
  17       ! Arguments
  18       character (len=*) :: s
  19
  20       ! Return value
  21       character (len=STRSIZE) :: get_path
  22
  23       ! Local variables
  24       integer :: n, i
  25
  26       n = len(s)
  27
  28       if (n > STRSIZE) then
  29          write(6,*) 'ERROR: Maximum string length exceeded in get_path()'
  30          stop
  31       end if
  32
  33       write(get_path,'(a)') './'
  34
  35       do i=n,1,-1
  36          if (s(i:i) == '/') then
  37             write(get_path,'(a)') s(1:i)
  38             exit
  39          end if
  40       end do
  41
  42    end function get_path
  43
  44
  45    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  46    ! Name: despace
  47    !
  48    ! Purpose: Remove all space and tab characters from a string, thus compressing
  49    !          the string to the left.
  50    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  51    subroutine despace(string)
  52
  53       implicit none
  54
  55       ! Arguments
  56       character (len=*), intent(inout) :: string
  57
  58       ! Local variables
  59       integer :: i, j, length, iquoted
  60
  61       length = len(string)
  62
  63       iquoted = 0
  64       j = 1
  65       do i=1,length
  66          ! Check for a quote mark
  67          if (string(i:i) == '"' .or. string(i:i) == '''') iquoted = mod(iquoted+1,2)
  68
  69          ! Check for non-space, non-tab character, or if we are inside quoted text
  70          if ((string(i:i) /= ' ' .and. string(i:i) /= achar(9)) .or. iquoted == 1) then
  71             string(j:j) = string(i:i)
  72             j = j + 1
  73          end if
  74       end do
  75
  76       do i=j,length
  77          string(i:i) = ' '
  78       end do
  79
  80    end subroutine despace
  81
  82
  83    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  84    ! Name: right_justify
  85    !
  86    ! Purpose: The non-space characters in s are shifted so that they end at
  87    !          position n. The argument s is modified, so if the original string
  88    !          must be preserved, a copy should be passed to right_justify.
  89    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  90    subroutine right_justify(s,n)
  91
  92       implicit none
  93
  94       ! Arguments
  95       integer, intent(in) :: n
  96       character (len=*), intent(inout) :: s
  97
  98       ! Local variables
  99       integer :: i, l
 100
 101       l = len_trim(s)
 102
 103       if (l >= n) return
 104
 105       do i=l,1,-1
 106          s(i+n-l:i+n-l) = s(i:i)
 107       end do
 108
 109       do i=1,n-l
 110          s(i:i) = ' '
 111       end do
 112
 113    end subroutine right_justify
 114
 115 end module stringutil